|
代码如下。。。
Sub test()
Application.ScreenUpdating = False
ReDim brr(1 To 1, 1 To 6)
Set fso = CreateObject("scripting.filesystemobject")
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Set d = CreateObject("scripting.dictionary")
r = ws.Cells(Rows.Count, 1).End(3).Row
arr = ws.[a3].Resize(r - 2, 8)
For i = 1 To UBound(arr)
d(arr(i, 2)) = i
Next
p = ThisWorkbook.Path & "\"
wb_name = fso.getbasename(wb.Name)
For Each f In fso.getfolder(p).Files
If InStr(f.Name, wb_name) = 0 Then
If LCase(f.Name) Like "*.xls*" Then
n = 1
With Workbooks.Open(f, 0)
s = .Sheets("基本信息").[c5]
If d.exists(s) Then
brr(n, 1) = .Sheets("基本信息").[c7]
brr(n, 2) = .Sheets("基本信息").[c14]
brr(n, 3) = .Sheets("同一品牌").[c3]
brr(n, 4) = .Sheets("服务资本市场").[c4]
brr(n, 5) = .Sheets("服务高质量发展").[c4]
brr(n, 6) = "已报"
.Close 0
ws.Cells(d(s) + 2, 3).Resize(, 6) = brr
End If
End With
End If
End If
Next
With ws
For i = 1 To UBound(arr)
If .Cells(i + 2, 8) <> "已报" Then .Cells(i + 2, 8) = "未找到"
Next
End With
Beep
Application.ScreenUpdating = True
Set fso = Nothing
Set d = Nothing
End Sub
|
|