|
附件中工作簿1中含有 “检测报告”工作表,工作簿2中则没有出现如图错误
请大神加个判断如果不含有“”检测报告“ 内容不添加进数组里,(不打开工作簿情况下)
Sub checkclosedfile()
Dim strPath As String, strFile As String
Dim strSheet As String, strResult As String
Dim i As Integer
Dim j As Integer
Dim r As String
Dim m As Integer
Dim n As Integer
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim vFill()
Dim brr()
Dim arr()
brr() = Range("b3:Z3").Value
Sheet1.[A5:zz200].ClearContents
strPath = ThisWorkbook.Path
strSheet = "检测报告"
Application.ScreenUpdating = False
Set fso = CreateObject("scripting.filesystemobject")
Set ff = fso.getfolder(ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径,路径名可以根据需求修改
'ActiveSheet.UsedRange.ClearContents
Dim Crr(1 To 1, 1 To 100) As Variant
a = 1
b = 0
For Each f In ff.Files
If f.Name Like "*.xls*" Then
If Not f.Name Like "*$*" Then
If f.Name <> ThisWorkbook.Name Then
Crr(1, a) = f.Name '相对路径名
a = a + 1
b = b + 1
End If
End If
End If
Next f
ReDim Preserve vFill(1 To b, 1 To 25) As Variant
For c = 1 To b
strFile = Crr(1, c)
If Dir(strPath & "\" & strFile) <> "" Then
vFill(c, 1) = strFile
For i = 2 To 25
r = brr(1, i)
If r <> "" Then
vFill(c, i) = GetCellvalue(strPath, strFile, strSheet, r)
End If
Next
End If
Next
ThisWorkbook.Activate '本工作簿激活为使用状态
With Sheets("sheet1") '对”汇总“表进行操作
.[a5].Resize(b, 25) = vFill
End With '结束对”汇总“表进行操作
Application.ScreenUpdating = True
End Sub
Public Function GetCellvalue(strPath As String, strFile As String, strSheet As String, strA1 As String)
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
If Dir(strPath & strFile) = "" Then
Err.Raise 12345, "getcellvalue", "no found file"
Exit Function
End If
GetCellvalue = ExecuteExcel4Macro("'" & strPath & "[" & strFile & "]" & strSheet & "'!" & Range(strA1).Address(, , xlR1C1))
End Function
|
|