此代码现在正在搜索多个工作表中的多个值。 如何修复它以支持同时搜索多个值而无需编写每个值。例如，我想在列A中放入我的所有搜索值，然后单击搜索，它应该搜索并同时为所有这些值赋值。我应该在代码中更改什么才能执行此功能？ 请参阅代码和图片。
Dim i, j, k, l, m, n, no_sheets As Variant
Dim key, cursor, sheetname As Variant
Dim flag As Variant
Dim sheet1_count, sheet1_row, row_count As Integer
Dim Arr() As Variant
sheet1_count = WorksheetFunction.CountA(ThisWorkbook.Worksheets("sheet1").Range("A:A"))
no_sheets = 3 ' Number of sheets
k = 2
sheet1_row = sheet1_count 'My start in result sheet
key = ThisWorkbook.Worksheets("sheet1").Range("A" & sheet1_count) ' The value that the user will put in searching sheet in column A
For i = 2 To no_sheets ' sheet2 then sheet3 then sheet4 then sheet5 ..etc
flag = False
sheetname = "Sheet" & i
row_count = WorksheetFunction.CountA(ThisWorkbook.Worksheets(sheetname).Range("A:A")) ' It's a counter that will contain the range of row A in each sheet
For j = 1 To row_count 'I'll start from row 1 until the last sheet
cursor = ThisWorkbook.Worksheets(sheetname).Range("A" & j) 'Searching in column A in each sheet (1st row - last row) and put the value in this variable
If key = cursor Then ' If the entering value in sheet1 equal the value that we have in current sheet, do the following
' Copying the data
flag = True ' The data found
ThisWorkbook.Worksheets("sheet1").Range("A" & sheet1_row) = ThisWorkbook.Worksheets(sheetname).Range("A" & j)
ThisWorkbook.Worksheets("sheet1").Range("B" & sheet1_row) = ThisWorkbook.Worksheets(sheetname).Range("B" & j)
ThisWorkbook.Worksheets("sheet1").Range("C" & sheet1_row) = ThisWorkbook.Worksheets(sheetname).Range("C" & j)
ThisWorkbook.Worksheets("sheet1").Range("D" & sheet1_row) = ThisWorkbook.Worksheets(sheetname).Range("D" & j)
ThisWorkbook.Worksheets("sheet1").Range("E" & sheet1_row) = ThisWorkbook.Worksheets(sheetname).Range("E" & j)
ThisWorkbook.Worksheets("sheet1").Range("F" & sheet1_row) = ThisWorkbook.Worksheets(sheetname).Range("F" & j)
sheet1_row = sheet1_row + 1
Else
End If
Next j 'Go to the next row
Next i 'Go to the next sheet
MsgBox "finished, Do another search..!"
If key <> cursor Then
flag = False ' If the value not found
ThisWorkbook.Worksheets("sheet1").Range("B" & sheet1_row) = "Not found"
ThisWorkbook.Worksheets("sheet1").Range("C" & sheet1_row) = "Not found"
ThisWorkbook.Worksheets("sheet1").Range("D" & sheet1_row) = "Not found"
ThisWorkbook.Worksheets("sheet1").Range("E" & sheet1_row) = "Not found"
End If
End Sub
Sub MatchUnMatch_Click()
Dim i, j, k, l, m, n As Integer
Dim ListA_count, ListB_count, ListC_count, ListD_count, ListE_count As Integer
Dim key, cursor As String
Dim flag As Boolean
ListA_count = WorksheetFunction.CountA(ThisWorkbook.Worksheets("MatchUnmatch").Range("A:A"))
ListB_count = WorksheetFunction.CountA(ThisWorkbook.Worksheets("MatchUnmatch").Range("B:B"))
'ListA_count = ThisWorkbook.Worksheets("MatchUnMatch").Range("A2").End(xlDown).Row
'MsgBox ListA_count & " " & ListB_count
'=======================================================================================================
'
'
' Matching Logic for List 'A' and List 'B'
'
'
'=======================================================================================================
k = 2
For i = 2 To ListA_count
key = ThisWorkbook.Worksheets("MatchUnMatch").Range("A" & i)
For j = 1 To ListB_count
cursor = ThisWorkbook.Worksheets("MatchUnMatch").Range("B" & j)
'MsgBox "Key=" & Key & " Cursor=" & cursor
If key = cursor Then
ThisWorkbook.Worksheets("MatchUnMatch").Range("C" & k) = key
k = k + 1
Exit For
End If
Next j
Next i
'=======================================================================================================
'
'
' List 'A' items not in List 'B'
'
'
'=======================================================================================================
ListC_count = WorksheetFunction.CountA(ThisWorkbook.Worksheets("MatchUnmatch").Range("C:C"))
k = 2
For i = 2 To ListA_count
key = ThisWorkbook.Worksheets("MatchUnMatch").Range("A" & i)
flag = False
For j = 1 To ListC_count
cursor = ThisWorkbook.Worksheets("MatchUnMatch").Range("C" & j)
If key = cursor Then
flag = True
Exit For
End If
Next j
If flag = False Then
ThisWorkbook.Worksheets("MatchUnMatch").Range("D" & k) = key
k = k + 1
End If
Next i
'=======================================================================================================
'
'
' List 'B' items not in List 'A'
'
'
'=======================================================================================================
k = 2
For i = 2 To ListB_count
key = ThisWorkbook.Worksheets("MatchUnMatch").Range("B" & i)
flag = False
For j = 1 To ListC_count
cursor = ThisWorkbook.Worksheets("MatchUnMatch").Range("C" & j)
If key = cursor Then
flag = True
Exit For
End If
Next j
If flag = False Then
ThisWorkbook.Worksheets("MatchUnMatch").Range("E" & k) = key
k = k + 1
End If
Next i
End sub
see the image please, to understand what I mean我想在搜索表（第一张）中放入A行许多数字，然后我想只点击搜索按钮一次，它应该同时给我所有的值。我不要＆ ＃39;我想多次点击一次搜索。 我希望有人为我解决这个问题。尽快:(
答案 0 :(得分：0)
现在我完全理解了这个问题，我编辑了我的初始脚本。现在它在第一个FIND之后包含一个FINDNEXT循环，它会搜索工作表上的所有重复值。这将循环，直到FINDNEXT.cell.address与FIND.cell.address相同。仅在列中搜索＆＃34; A＆＃34;我在查找功能中将工作表（i）.slls更改为工作表（i）.Range（＆＃34; A：A＆＃34;）
Sub find_cells()
Dim find_cell As Range
Dim colection_items As Collection
Dim look_up_value As String
nb_rows = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row 'count the number of rows with data on sheet(1)
Set colection_items = New Collection
For j = 2 To nb_rows
colection_items.Add Sheets(1).Cells(j, 1).Value
Next j
counter_rows = 2 'the first row on sheet(2) where we start copying data from
For col = 1 To colection_items.Count
look_up_value = colection_items(col)
For i = 2 To ThisWorkbook.Sheets.Count
Sheets(i).Select
Set find_cell = Sheets(i).Range("A:A").Find(What:=look_up_value, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlRows, SearchDirection:=xlNext, MatchCase:=False)
If Not find_cell Is Nothing Then
Dim cell_adrs As String
cell_adrs = find_cell.Address 'record address of the first instance of the lookup value on the sheet (i)
Sheets(1).Cells(counter_rows, 1).Value = find_cell
Sheets(1).Cells(counter_rows, 2).Value = find_cell.Offset(0, 1) 'copies data from the cell to the left by one column
Sheets(1).Cells(counter_rows, 3).Value = find_cell.Offset(0, 2) 'copies data from the cell to the left by 2 columns
'etc
counter_rows = counter_rows + 1
Do
Set find_cell = Sheets(i).Range("A:A").FindNext(find_cell) 'we lookup the next instance on sheet (i)
If cell_adrs <> find_cell.Address Then 'if the next value found is different than the first value from sheet(i)
Sheets(1).Cells(counter_rows, 1).Value = find_cell
Sheets(1).Cells(counter_rows, 2).Value = find_cell.Offset(0, 1) 'copies data from the cell to the left by one column
Sheets(1).Cells(counter_rows, 3).Value = find_cell.Offset(0, 2) 'copies data from the cell to the left by 2 columns
counter_rows = counter_rows + 1
'etc
End If
Loop Until cell_adrs = find_cell.Address 'when all the values have been found and find_cell goes back to the first value
cell_adrs = Empty
End If
Next i
Next col
Sheets(1).Select
End Sub
答案 1 :(得分：0)
（*）更新，并且在＆＃34;数据＆＃34;中找不到数字。标记为＆＃34; NOT FOUND＆＃34;
的表格 在OP处理可变数量的列的请求之后，（**）更新
（***）更新以修复FindItems（）函数以处理非连续的单元格范围
更新（****）以修复子Main（）
中的iRow更新
（*****）更新，以便在其单元格＆＃34; A1＆＃34;具有与＆＃34; base＆＃34;相同的内容床单
更新（******）以在所有数据表的A列中搜索项目，无论该列的标题是什么
当我在做我的代码时，Cornel已经给你一个答案，这是好的
但是你应该想管理：
任何不同数量的＆＃34;数据＆＃34;表格（即：用于在其栏目中搜索项目编号的表格＆＃34; A＆＃34;并从相邻列收集相关数据）
多次出现＆＃34;数字＆＃34;在任何＆＃34;数据＆＃34;片
（*）保存先前数据的功能＆＃34; base＆＃34;以前运行产生的工作表
（*）标记＆＃34; NOT FOUND＆＃34; in＆＃34; base＆＃34;在任何＆＃34;数据＆＃34;片
（**）处理可变数量列的功能
然后您可能想要使用以下代码
Option Explicit
Sub main()
Dim items() As Variant, itemToFind As Variant
Dim itemsNumber As Long, previousDataNumber As Long, dataShtNumber As Long, iRow As Long, i As Long, j As Integer
Dim itemsSht As Worksheet, dataShts() As Worksheet
Dim rngToCopy As Range
Dim itemFound As Boolean
Dim columnsNumberToCopyAndPaste As Long
columnsNumberToCopyAndPaste = 7 '<== here you set the number of columns to be copied form "data" sheet and pasted in "base" sheet
Set itemsSht = ThisWorkbook.Worksheets("Sheet1") ' this is the "base" sheet you take "numbers" from its column A, starting at row 2
Call GetItems(itemsSht, items(), itemsNumber, previousDataNumber) ' gather all "numbers" to be searched for in "data" sheets
Call GetDataWorksheets(dataShts(), ThisWorkbook, "Sheet1", dataShtNumber) ' gather all "data" sheets
iRow = 1
For i = 1 To itemsNumber 'loop through "numbers"
itemToFind = items(i) ' "number" to be searched for in "data" sheets
itemFound = False
For j = 1 To dataShtNumber 'loop through "data" worksheets
Set rngToCopy = FindItems(dataShts(j), itemToFind, 1, columnsNumberToCopyAndPaste) ' get "data" sheet column 1 cells with "number" along with 'columnsNumberToCopyAndPaste-1' adjacents cells
If Not rngToCopy Is Nothing Then ' if found any occurrence of the "number" ...
rngToCopy.Copy itemsSht.Cells(1, 1).Offset(previousDataNumber + iRow) ' ... copy it and paste into "base" sheet
iRow = iRow + rngToCopy.Count / columnsNumberToCopyAndPaste 'update "base" sheet row offset to paste subsequent cells, if any
itemFound = True
End If
Next j
If Not itemFound Then 'if NOT found any occurrence of the "number" ...
itemsSht.Cells(1, 1).Offset(previousDataNumber + iRow).Value = itemToFind
itemsSht.Cells(1, 2).Offset(previousDataNumber + iRow).Resize(1, columnsNumberToCopyAndPaste - 1).Value = "NOT FOUND"
iRow = iRow + 1
End If
Next i
itemsSht.Columns.AutoFit
End Sub
Sub GetItems(itemsSht As Worksheet, items() As Variant, itemsNumber As Long, previousDataNumber As Long)
With itemsSht
previousDataNumber = .Cells(.Rows.Count, 2).End(xlUp).Row - 1
itemsNumber = .Cells(.Rows.Count, 1).End(xlUp).Row - 1 - previousDataNumber
ReDim items(1 To itemsNumber) As Variant
With .Cells(2 + previousDataNumber, 1).Resize(itemsNumber)
If itemsNumber = 1 Then
items(1) = .Value
Else
items = WorksheetFunction.Transpose(.Value)
End If
End With
End With
End Sub
Function FindItems(sht As Worksheet, itemToFind As Variant, columnToSearchFor As Long, columnsToCopy As Long) As Range
Dim cell As Range, unionRng As Range
Dim firstAddress As String
With sht.Columns(columnToSearchFor)
Set cell = .Find(What:=itemToFind, LookAt:=xlWhole)
If Not cell Is Nothing Then
firstAddress = cell.Address
Set unionRng = cell.Resize(, columnsToCopy)
Do
Set unionRng = Union(unionRng, cell.Resize(, columnsToCopy))
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address <> firstAddress
Set FindItems = unionRng
End If
End With
End Function
Sub GetDataWorksheets(shts() As Worksheet, wb As Workbook, noShtName As String, nShts As Long)
Dim sht As Worksheet
For Each sht In wb.Worksheets
With sht
If .Name <> noShtName Then
nShts = nShts + 1
ReDim Preserve shts(1 To nShts) As Worksheet
Set shts(nShts) = sht
End If
End With
Next sht
End Sub
（*）实际上我添加了一个previousDataNumber变量来跟踪例程运行时已存在的数据
（**）在columnsNumberToCopyAndPaste = 5中设置要处理的列数
我将它拆分为＆＃34; main＆＃34; sub和其他一些＆＃34; helper＆＃34;子或函数，以便有清晰，可维护/可更改的代码。
当我习惯于编码looong潜艇时，这种习惯对我的启发总是比我想象的要多得多。