需要復制/粘貼結果所在的行

VBA 很新。我想知道是否有人可以幫助我的代碼的底部。我實際上是想在 WB1（活動 WB）中擁有一個值（“A2”），并在另一個 WB（目的地）中找到相同的值。一旦找到，我希望將 Active WB ("B2:L2") 中的范圍粘貼到目標作業簿上單元格所在的任何位置。

目前我定居并將其粘貼在某個位置（B2：K2）。

Sub VlookUp_Copy_Paste_Other_WB()

i = ThisWorkbook.ActiveSheet.Range("A2").Value

m = Application.Match(i, Workbooks("destination.xlsx").Sheets(1).Range("A:A"), 0)

If IsError(m) = True Then

MsgBox "The Value Is Not Found"

Exit Sub

End If

ThisWorkbook.ActiveSheet.Range("B2:L2" & m).Select

Selection.Copy

Workbooks("destination.xlsx").Activate

Sheets(1).Range("B2:K2").PasteSpecial

Application.CutCopyMode = False

End Sub

uj5u.com熱心網友回復：

這應該有效：

Sub VlookUp_Copy_Paste_Other_WB()
    Set this = ThisWorkbook
    Set dest = Workbooks("destination.xlsx")
    lookfor = this.ActiveSheet.Range("A2").Value
    Set foundlocation = dest.Sheets(1).Range("A:A").Find(What:=lookfor, After:=dest.Sheets(1).Range("A1"), LookIn:=xlValues, LookAt _
        :=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    If foundlocation Is Nothing Then
        MsgBox "The Value Is Not Found"
        Exit Sub
    Else
        this.ActiveSheet.Range("B2:L2").Copy
        dest.Sheets(1).Range("B" & foundlocation.Row).PasteSpecial
        Application.CutCopyMode = False
    End If
End Sub

uj5u.com熱心網友回復：

您可以使用 m 作為行號來粘貼值。注意：您應該打開目標 wb.

試試下面

Sub VlookUp_Copy_Paste_Other_WB()

    i = ThisWorkbook.ActiveSheet.Range("A2").Value
    m = Application.Match(i, Workbooks("destination.xlsx").Sheets(1).Range("A:A"), 0)
    If IsError(m) = True Then
    MsgBox "The Value Is Not Found"
    Exit Sub
    End If
    ThisWorkbook.ActiveSheet.Range("B2:L2").Copy Workbooks("destination.xlsx").Sheets(1).Cells(m, "B")
    End Sub

對于某些自動化，使用下面的代碼，您將提示您選擇目標檔案，它將自動更新而無需打開它

Dim FileToOpen As Variant
Sub VlookUp_Copy_Paste_Other_WB()
    FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen <> False Then
        Update
    End If
End Sub
Sub Update()

    Dim dst As Workbook
    Dim missingValues As Integer
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    ' OPEN THE DST EXCEL WORKBOOK.
    Set dst = Workbooks.Open(FileToOpen, ReadOnly:=False)


' COPY DATA TO DST TO THE DESTINATION WORKBOOK.
    
        For i = 2 To dst.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row
            
          lookUpValue = dst.ActiveSheet.Range("A" & i).Value
          lookUpValueRowInSrc = Application.Match(lookUpValue, ThisWorkbook.Worksheets(1).Range("A:A"), 0)
            If IsError(lookUpValueRowInSrc) Then
                If lookUpValue <> "" Then
                missingValues = missingValues   1
                End If
GoTo ContinueForLoop:
            End If
          ThisWorkbook.Worksheets(1).Range("B" & lookUpValueRowInSrc & ":L" & lookUpValueRowInSrc).Copy dst.Worksheets(1).Cells(i, "B")
ContinueForLoop:
       Next i
 
 
 On Error GoTo ErrHandler

    
    Application.DisplayAlerts = True
 
  

    dst.Close True             ' TRUE - SAVE THE DST FILE.
    Set dst = Nothing
    If missingValues > 0 Then
        MsgBox "Total missing values are " & missingValues
    End If
ErrHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    End Sub

uj5u.com熱心網友回復：

一種 VBA 查找

Option Explicit

Sub VlookUp_Copy_Paste_Other_WB()
    
    Dim sws As Worksheet: Set sws = ThisWorkbook.ActiveSheet
    ' Usually you know the (tab) name of the worksheet i.e. better is e.g.:
    'Set sws = ThisWorkbook.Worksheets("Sheet1")
    
    Dim sValue As Variant: sValue = sws.Range("A2").Value
    
    Dim dws As Worksheet: Set dws = Workbooks("Destination.xlsx").Sheets(1)
    ' More accurate is ...
    'Set dws = Workbooks("Destination.xlsx").Worksheets(1)
    ' ... but again, usually you know the (tab) name i.e. safer is e.g.:
    'Set dws = Workbooks("Destination.xlsx").Worksheets("Sheet1")
    
    Dim drg As Range: Set drg = dws.Columns("A")
    
    Dim dIndex As Variant
    dIndex = Application.Match(sValue, drg, 0)
    
    If IsError(dIndex) Then
        MsgBox "The value was not found.", vbExclamation
        Exit Sub
    End If
    
    Dim srg As Range: Set srg = sws.Range("B2:L2")
    Dim dfCell As Range: Set dfCell = drg.Cells(dIndex).Offset(0, 1)
    ' or:
    'Set dfCell = drg.Cells(dIndex).EntireRow.Columns("B")
    
    srg.Copy dfCell
    ' which is short for:
    'srg.Copy Destination:=dfCell
    
    MsgBox "Data copied.", vbInformation
    
End Sub

標籤：擅长 vba

上一篇：MSAccessVBA相當于Ctrl '？

下一篇：回圈索引混亂