VBA 代码从一张纸到另一张纸搜索列数据并将相应的行数据粘贴到第一张纸上

如何解决VBA 代码从一张纸到另一张纸搜索列数据并将相应的行数据粘贴到第一张纸上

我是 VBA 的新手，我找不到任何解决我问题的方法。 我有两本包含数据的工作簿。在工作簿1中有一个名称列A.在工作簿2中还有一个名称列A和从B列到D列的其他数据。我需要在工作簿1的A列中从workbook2的A列中搜索名称，如果名称匹配，我需要在 workbook1 中粘贴相应的行。另请注意，在 workbook2 中可能有多个相同名称的条目..因此在这些情况下，这些行值必须连接并粘贴到 workbook1 上。

请帮忙

将 AVals 变暗为新词典 Dim k As Long,j As Long,lastRow1 As Long,lastRow2 As Long Dim sh_1,sh_3 作为工作表 将 MyName 调暗为字符串 Dim tmpCollection 作为集合 Set sh_1 = Sheets("snipe-sample-assets blank") Dim 键作为变体

inputRowMin = 1
inputRowMax = 288
inputColMin = 1
inputColMax = 9
equipmentCol = 4
dimensionCol = 9

Set equipmentDictionary = CreateObject("Scripting.Dictionary")
equipmentDictionary.CompareMode = vbTextCompare
Set inputSheet = Application.Sheets("Verizon WirelessNumbers_2021033")
Set inputRange = Range(Cells(inputRowMin,inputColMin),Cells(inputRowMax,inputColMax))
Set equipmentCollection = New Collection

For i = 1 To inputRange.Height
    thisEquipment = inputRange(i,equipmentCol).Text
    nextEquipment = inputRange(i + 1,equipmentCol).Text
    thisDimension = inputRange(i,dimensionCol).Text

    'The Strings are equal - add thisEquipment to collection and continue
    If (StrComp(thisEquipment,nextEquipment,vbTextCompare) = 0) Then
        equipmentCollection.Add thisDimension
    'The Strings are not equal - add thisEquipment to collection and the collection to the dictionary
    Else
        equipmentCollection.Add thisDimension
        equipmentDictionary.Add thisEquipment,equipmentCollection
        Set equipmentCollection = New Collection
    End If

Next

'Set sh_3 = Sheets("sheet2")

lastRow2 = sh_1.Range("A:A").Rows.Count
lastRow2 = sh_1.Cells(lastRow2,2).End(xlUp).Row 'last used row in column 2
'MsgBox lastRow2

For j = 2 To lastRow2
    MyName = UCase(sh_1.Cells(j,2).Value)
    For Each key In equipmentDictionary.Keys
        If (StrComp(MyName,key,vbTextCompare) = 0) Then
            Set tmpCollection = equipmentDictionary.Item(MyName)
            For k = 1 To tmpCollection.Count
                sh_1.Cells(j,10).Value = tmpCollection.Item(k)
            Next
        End If
        
    Next
    
Next j

解决方法

快速了解您的需求

'You declare all these based on where your data resides
sheetName1 = "Sheets1"
sheetName2 = "Sheets2"
wbName1 = activeworkbook.name
wbName2 = activeworkbook.name   'I've included this for where you might want to fork solution to work off two workbooks

'Loop through entries in sheetName1
iRows1 = 1
Do Until IsEmpty(workbooks(wbName1).sheets(sheetName1).cells(iRows1,1))
    sourceName = workbooks(wbName1).sheets(sheetName1).cells(iRows1,1)

    'Loop through entries in sheetName2
    colB = ""
    colC = ""
    colD = ""
    iRows2 = 1
    Do Until IsEmpty(workbooks(wbName2).sheets(sheetName2).cells(iRows2,1))
        if workbooks(wbName2).sheets(sheetName2).cells(iRows2,1) = sourceName then
            'If there is a match then append. If you want to delimit,then you'd need to add in a delimiter & "," for example
            colB = colB & workbooks(wbName2).sheets(sheetName2).cells(iRows2,2).text
            colC = colC & workbooks(wbName2).sheets(sheetName2).cells(iRows2,3).text
            colD = colD & workbooks(wbName2).sheets(sheetName2).cells(iRows2,4).text
        end if
        iRows2 = iRows2 + 1
    Loop

    if colB <> "" then
        'Found something,send it to sheetName1
        workbooks(wbName1).sheets(sheetName1).cells(iRows1,2) = colB
        workbooks(wbName1).sheets(sheetName1).cells(iRows1,3) = colC
        workbooks(wbName1).sheets(sheetName1).cells(iRows1,4) = colD
    end if

    iRows1 = iRows1 + 1
Loop

如果要为单独的工作簿执行此操作，则需要分配一个 wbName2。我对 ActiveWorkbook 的使用假定它会用完您要粘贴到的工作簿。它还假定您已打开两个工作簿。我相信你可以自己弄清楚这一点。