[已解决]提取所有名字

张雄友 · 发表于 2014-11-9 16:29

提取所有名字，实现效果。

Sub Get_All_Names()
Cells.Clear
Dim arr, s&, i&, j&, k$, myPath$, myFile$
myPath = ThisWorkbook.Path & ""
myFile = Dir(myPath & "*.xls*")
s = CreateObject("Scripting.FileSystemObject").GetFolder(myPath).Files.Count - 1
ReDim arr(1 To 1000, 1 To s)
Do While myFile <> ""
If myFile <> ThisWorkbook.Name Then
j = j + 1
i = 1
arr(1, j) = Left(myFile, InStrRev(myFile, ".") - 1) & "："
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & myPath & myFile
Set rs = cnn.OpenSchema(20)
Do Until rs.EOF
If rs.Fields("TABLE_TYPE") = "TABLE" Then
i = i + 1
k = Replace(rs("TABLE_NAME").Value, "'", "")
arr(i, j) = Left(k, Len(k) - 1)
End If
rs.MoveNext
Loop
End If
myFile = Dir
Loop
Range("A3").Resize(i, j) = arr
Cells.EntireColumn.AutoFit
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
End Sub

复制代码

最佳答案

xdragon

2014-11-9 17:28

Sub Get_All_Names()
Cells.Clear
Dim arr, s&, i&, k$, myPath$, myFile$, sr$
myPath = ThisWorkbook.Path & ""
myFile = Dir(myPath & "*.xls*")
' s = CreateObject("Scripting.FileSystemObject").GetFolder(myPath).Files.Count - 1
ReDim arr(1 To 1000, 1 To 2)
Do While myFile <> ""
If myFile <> ThisWorkbook.Name Then
sr = Left(myFile, InStrRev(myFile, ".") - 1)
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & myPath & myFile
Set rs = cnn.OpenSchema(20)
Do Until rs.EOF
If rs.Fields("TABLE_TYPE") = "TABLE" Then
i = i + 1
k = Replace(rs("TABLE_NAME").Value, "'", "")
arr(i, 1) = sr
arr(i, 2) = "'" & Left(k, Len(k) - 1)
End If
rs.MoveNext
Loop
End If
myFile = Dir
Loop
Range("A3").Resize(i, 2) = arr
Range("A2:B2") = Array("工作簿名字", "工作表名字")
Cells.EntireColumn.AutoFit
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
End Sub

复制代码

xdragon · 发表于 2014-11-9 17:28

Sub Get_All_Names()
Cells.Clear
Dim arr, s&, i&, k$, myPath$, myFile$, sr$
myPath = ThisWorkbook.Path & ""
myFile = Dir(myPath & "*.xls*")
' s = CreateObject("Scripting.FileSystemObject").GetFolder(myPath).Files.Count - 1
ReDim arr(1 To 1000, 1 To 2)
Do While myFile <> ""
If myFile <> ThisWorkbook.Name Then
sr = Left(myFile, InStrRev(myFile, ".") - 1)
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & myPath & myFile
Set rs = cnn.OpenSchema(20)
Do Until rs.EOF
If rs.Fields("TABLE_TYPE") = "TABLE" Then
i = i + 1
k = Replace(rs("TABLE_NAME").Value, "'", "")
arr(i, 1) = sr
arr(i, 2) = "'" & Left(k, Len(k) - 1)
End If
rs.MoveNext
Loop
End If
myFile = Dir
Loop
Range("A3").Resize(i, 2) = arr
Range("A2:B2") = Array("工作簿名字", "工作表名字")
Cells.EntireColumn.AutoFit
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
End Sub

复制代码

		自动登录	找回密码
密码			注册