|
如标题所述。
已写了一段代码,已经可以初步实现此功能。(功能:从一堆工作簿里,查每个表,是否包含此字段,如有,列出路径和表名)
请教各位老师,是否代码中有什么可以改进的地方。(比如:查字段名这里?)
或者是否有更快的办法?
当然,如果有需要,欢迎大家可以正常使用此代码。
- Option Explicit
- Option Base 1
- Sub 自动识别()
- Dim ArrPath, ArrShtName, ArrTemp
- Dim i, j, k, n, TempShtCount, t As Integer
- Dim dic
- Dim Conn As New ADODB.Connection
- Dim Rst As New ADODB.Recordset
- Dim Cat As New ADOX.Catalog
- Dim Sql, ArrHk(1 To 10000) As String
- Dim findval As Variant
- Application.ScreenUpdating = False
- On Error Resume Next
- t = Timer
- ArrPath = Application.GetOpenFilename("Excel,*.xls*", , "选择EXCEL表", MultiSelect:=True)
- For i = 1 To UBound(ArrPath)
- Conn.Open "Provider = Microsoft.ACE.OLEDB.12.0;Data Source=" & ArrPath(i) & ";extended properties=""excel 12.0;HDR=NO"""
- Set Cat.ActiveConnection = Conn
- TempShtCount = Cat.Tables.Count
- ReDim ArrShtName(1 To TempShtCount)
- For n = 1 To TempShtCount
- If Not Cat.Tables(n - 1).Name Like "*_xlnm*" And Not Cat.Tables(n - 1).Name Like "*filterdatabase" Then '去除筛选表
- ArrShtName(n) = Cat.Tables(n - 1).Name
- Sql = "select * from [" & ArrShtName(n) & "a1:dw10]" '判断前10行(即表头字段,预估表头不会超过10行)
- Rst.Open Sql, Conn, 1, 1
- ArrTemp = Rst.GetRows
- Rst.Close
- Set Rst = Nothing
- For Each findval In ArrTemp
- If findval Like "*回款*期*" Or findval Like "*回款*天*" Then
- j = j + 1
- ArrHk(j) = ArrPath(i) & "|||" & ArrShtName(n)
- Exit For
- End If
- Next
- End If
- Next n
- Conn.Close
- Set Conn = Nothing
- Next i
- Range("a2").Resize(j, 1) = Application.WorksheetFunction.Transpose(ArrHk) '列举带有HK(回款)信息的表位置和表名
- MsgBox "耗时:" & Format(Timer - t, "00:00")
- Application.ScreenUpdating = True
- End Sub
复制代码
|
|