VBA 用于搜索从一个 sheet 到另一个的列数据并将相应的行数据粘贴到第一个 sheet 的代码
VBA code to search for a column data from one sheet to another and paste corresponding rows data onto first sheet
我是 VBA 的新手,我找不到解决问题的方法。
我有两个包含数据的工作簿。在 workbook1 中有一个名称列 A.In workbook2 还有一个名称 columnA 和从 B 列到 D 的其他数据。我需要在工作簿 1 的 A 列中从 workbook2 的 A 列搜索名称,如果名称匹配我需要粘贴工作簿 1 中的相应行。另请注意,在工作簿 2 中可能有多个相同名称的条目。因此在这些情况下,必须将这些行值连接起来并粘贴到工作簿 1 上。
请帮忙
Dim AVals 作为新词典
Dim k 一样长,j 一样长,lastRow1 一样长,lastRow2 一样长
将 sh_1、sh_3 调暗为工作表
将 MyName 调暗为字符串
Dim tmpCollection 作为集合
Set sh_1 = Sheets("snipe-sample-assets blank")
昏暗键作为变体
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 的使用假设它将 运行 超出您要粘贴到的工作簿。它还假定您已打开两个工作簿。我敢肯定,您可以自己解决这个问题。
我是 VBA 的新手,我找不到解决问题的方法。 我有两个包含数据的工作簿。在 workbook1 中有一个名称列 A.In workbook2 还有一个名称 columnA 和从 B 列到 D 的其他数据。我需要在工作簿 1 的 A 列中从 workbook2 的 A 列搜索名称,如果名称匹配我需要粘贴工作簿 1 中的相应行。另请注意,在工作簿 2 中可能有多个相同名称的条目。因此在这些情况下,必须将这些行值连接起来并粘贴到工作簿 1 上。
请帮忙
Dim AVals 作为新词典 Dim k 一样长,j 一样长,lastRow1 一样长,lastRow2 一样长 将 sh_1、sh_3 调暗为工作表 将 MyName 调暗为字符串 Dim tmpCollection 作为集合 Set sh_1 = Sheets("snipe-sample-assets blank") 昏暗键作为变体
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 的使用假设它将 运行 超出您要粘贴到的工作簿。它还假定您已打开两个工作簿。我敢肯定,您可以自己解决这个问题。