工作中用的代码
Sub ExcelVBA从工作簿中查询多个姓名并复制出整行数据()
Dim outFile As String, inFile As String
Dim outWb As Workbook, mysht As Worksheet, tempsht As Worksheet, t_arr(1 To 30)
Dim SearchRange As Range
Dim LastRow As Integer, arr, FindStr As String, inWbSheet As String
With Worksheets("设置")
outFile = .Range("B1").Value
LastRow = .Range("A200000").End(xlUp).Row
If Dir(outFile, 16) = Empty Or LastRow < 3 Then MsgBox ("初始数据不完整"): Exit Sub
arr = .Range("A3:A" & LastRow).Value
Debug.Print UBound(arr)
End With
Set mysht = Worksheets("结果")
Set tempsht = Worksheets("过程")
mysht.Cells.Clear
tempsht.Cells.Clear
disAppSet (False)
t = Timer()
FindStr = ""
Set outWb = Workbooks.Open(outFile)
With outWb
For i = 1 To UBound(arr)
FindStr = arr(i, 1)
For Each sht In .Sheets
With sht
Set SearchRange = .Cells.Find(What:=FindStr, After:=.Range("A1"))
' 如果已找到匹配项
If Not SearchRange Is Nothing Then
FirstAddress = SearchRange.Address
' Debug.Print FindStr & "-" & FirstAddress
Do '找到了,要做什么========
OutShtName = sht.Name
LastRow = getLastRow(mysht, t_arr) + 1
SearchRange.EntireRow.Copy mysht.Range("A" & LastRow)
TempRow = getLastRow(tempsht, t_arr) + 1
tempsht.Range("A" & TempRow) = OutShtName
Set SearchRange = .Cells.FindNext(SearchRange)
' 当不再找得到匹配项时, 退出过程
If SearchRange Is Nothing Then
Exit Sub
End If
' 在找到唯一匹配项时继续查找
Loop While SearchRange.Address <> FirstAddress
Else
' 则没有找到匹配的 MsgBox ("一个也没找到")
End If
'==end=工作表内部
End With
'''=end= for each sht in .Sheets
Next
'''==arr=行
FindStr = ""
Next i
.Close False
'===end= outWb
End With
tempsht.Columns("A:A").Copy
With Sheets("结果")
.Select
.Columns("A:A").Select
Selection.Insert Shift:=xlToRight
.UsedRange.Columns.AutoFit
End With
tempsht.Cells.Clear
Set outWb = Nothing
disAppSet (True)
MsgBox ("完成,用时:" & Format(Timer - t, "00.00秒"))
End Sub
''''用法:disAppSet(true)开disAppSet(true)关
Sub disAppSet(flag As Boolean)
With Application
.ScreenUpdating = flag
.DisplayAlerts = flag
.AskToUpdateLinks = flag
If flag Then
.Calculation = xlCalculationAutomatic
Else
.Calculation = xlCalculationManual
End If
End With
End Sub
''''判断工作表是否存在,本次没用到此函数
Function MyExistSh(Sh As String) As Boolean
Dim sht As Object
On Error Resume Next
Set sht = Sheets(Sh)
If Err.Number = 0 Then MyExistSh = True
Set sht = Nothing
End Function
'# # 输入工作表,空一维数组arr(1 to x),返回最大行数
Function getLastRow(sht, arr)
Dim ti As Integer
With sht
For ti = LBound(arr) To UBound(arr)
If ti <= 0 Then Exit For
arr(ti) = .Cells(Rows.Count, ti).End(xlUp).Row
Next ti
End With
getLastRow = Application.WorksheetFunction.Max(arr)
End Function