Question

我正试图从另一个wb导入细胞。因此，如果wb1 col H中的单元格与wb2 col K中的单元格匹配，则wb1 col k和L = wb2 col C和E在匹配行中。现在可能有几个匹配，所以我希望它偏移到下一列。 m和n用于下一组，o和p用于下一组，依此类推。

这是我到目前为止所做的：

Private Sub CommandButton1_Click()

Dim rcell As Range, sValue As String
Dim lcol As Long, cRow As Long
Dim dRange As Range, sCell As Range
Dim LastRow As Integer
Dim CurrentRow As Integer


Set ws1 = ThisWorkbook
Set ws2 = Workbooks("Workbook2").Worksheets("Sheet1")
Sheet1LastRow = ThisWorkbook.Sheets("Data").Range("H2:H50000").Value 'Search criteria column
Sheet2LastRow = Workbooks("Workbook2").Worksheets("Sheet1").Range("Q" & Rows.Count).End(xlUp).Row 'Where to look for matches

 With Workbooks("Workbook2").Worksheets("Sheet1")
     For j = 1 To Sheet1LastRow
         For i = 1 To Sheet2LastRow        
             If ThisWorkbook.Sheets("Data").Range("H").Value =  ws2.Cells(i, 11).Value Then
                 ws2.Cells(i, 11).Value = ThisWorkbook.Sheets("Data").Range("C").Value
                 ws2.Cells(i, 12).Value = ThisWorkbook.Sheets("Data").Range("E").Value
             End If
             If InStr(1, ws2.Cells.Value, ws1.Cells.Value) And     Trim(ws1.Cells.Value) <> "" Then
                 rcell.Offset(0, lcol).Value = ws2.Cells.Offset(0, 2).Value
                 lcol = lcol + 1
             End If
         Next i
     Next j
 End With

End Sub

这不起作用。我基本上放弃了，因为我不知道我错过了什么。

我找了类似这样的东西，但只发现Vlookup或Match可以做的事情。

Answer 1

您可以通过跟踪每次复制匹配后移位2的偏移来实现。我将在名为offs的变量中跟踪此情况。另外我认为复制从文本中描述的从wb2到wb1 ，而不是＆＃34;怀疑＆＃34;在代码中。

Private Sub CommandButton1_Click()
    Dim cel1 As Range, cel2 As Range
    For Each cel1 In ThisWorkbook.Sheets("Data").UsedRange.Columns("H").Cells
        Dim offs As Long: offs = 3 ' <-- Initial offset, will increase by 2 after each match
        For Each cel2 In Workbooks("Workbook2").Worksheets("Sheet1").UsedRange.Columns("K").Cells
            If cel1.Value = cel2.Value Then
                cel1.offset(, offs).Value = cel2.offset(, -8).Value ' <- wb2(C) to wb1(K)
                cel1.offset(, offs + 1).Value = cel2.offset(, -6).Value ' <- wb2(E) to wb1(L)
                offs = offs + 2 ' <-- now shift the destination column by 2 for next match
            End If
        Next
    Next
End Sub

Excel VBA将多个匹配导入到同一行的不同列中

1 个答案: