不知道为什么,用标签粘贴代码总是有几个显示不全,直接贴一下:
Sub test()
Dim cnn As Object, rst As Object
Dim arr, wkb$, wkt$, str$, i%, k%
Set cnn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
arr = [h12:h149]
ReDim brr(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr)
k = InStr(arr(i, 1), "]")
If k > 6 Then
wkb = Mid(arr(i, 1), 2, k - 2)
If Dir(ThisWorkbook.Path & "\" & wkb) = "" Then
brr(i, 1) = "无此档案"
Else
wkt = Replace(Mid(arr(i, 1), k + 1, InStr(arr(i, 1), "!") - k - 2), ".", "#")
cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no;imex=1';data source=" & ThisWorkbook.Path & "\" & wkb
' cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0 Xml;HDR=no;imex=1';Data Source=" & ThisWorkbook.Path & "\" & wkb
Set rst = cnn.OpenSchema(20)
Do Until rst.EOF
If rst!TABLE_TYPE = "TABLE" And Right(rst!TABLE_NAME.Value, 2) = "$'" Then
str = Replace(Replace(rst!TABLE_NAME.Value, "'", ""), "$", "")
End If
If wkt = str Then brr(i, 1) = "有此档案": k = 0: Exit Do
rst.MoveNext
Loop
If k > 0 Then brr(i, 1) = "无此档案"
rst.Close
cnn.Close
End If
Else
brr(i, 1) = ""
End If
Next
[j12].Resize(UBound(brr)) = brr
MsgBox "整理结束", , "提示"
End Sub