Sub 导入文件()
Application.ScreenUpdating = False
Dim Filename, wb As Workbook, Sht As Worksheet, xRng As Range
Filename = Dir(ThisWorkbook.Path & "\*.xls")
arr = [a2:p2] '本表第二行数据,用于确定在打开文件中查找内容(WDA、键盘、鼠标、主机、折后a、折后b、折后c、折后d、折后e、折后f)
ReDim brr(1 To 100, 1 To UBound(arr, 2)) '结果数组
r = [a65536].End(3).Row + 1 '需要导入数据的起始行
s = Val(Cells(r - 1, 1)) '已有数据的序号
Do While Filename <> ""
If Filename <> ThisWorkbook.Name Then
fn = ThisWorkbook.Path & "\" & Filename
Set wb = Workbooks.Open(fn, Password:="123") '打开文件,密码123
Set Sht = wb.Worksheets(1) '打开文件的第一个工作表
n = n + 1
brr(n, 1) = s + n: brr(n, 2) = Sht.[c2]: brr(n, 3) = Sht.[M2] '序号、日期、流水号
For j = 4 To UBound(arr, 2)
x = arr(1, j) '要查找的内容(WDA、键盘、鼠标、主机、折后a、折后b、折后c、折后d、折后e、折后f)
Set xRng = Sht.UsedRange.Find(x, lookat:=xlWhole) '在打开工作表中查找第二行各列的内容
If Not xRng Is Nothing Then '如果找到
If j <= 10 Then brr(n, j) = xRng.Offset(0, 1) Else brr(n, j) = xRng.Offset(1, 0) '读取相应内容进数组
End If
Next
wb.Close False
End If
Filename = Dir '读取下一个文件
Loop
Set Sht = Nothing
Cells(r, 1).Resize(n, UBound(brr, 2)) = brr '显示结果
Application.ScreenUpdating = True
End Sub