怎么选择文件夹（含子文件夹）获取所有文件

ykcbf1100

limonet 发表于 2024-4-30 20:50
本想写写，但真看不惯：丢个问题就跑的行为。

用SQL还真无法处理这题的数据，因为要一个单元格一个单元格的提取，而且数量很多。

baofa2

1. Sub test1() 'SQL写法练习，仅供参考，通用Excel和WPS……
   
2.   Dim Files_(), Path_ As String
   
3.   Path_ = ThisWorkbook.Path & "\测试\"
   
4.   If Not GetFileName(Files_, Path_, ".xls") Then MsgBox "!": Exit Sub
   
5.   
   
6.   Dim results(), ar, br(1), cel As Range
   
7.   Dim i As Long, j As Long, cnt As Long, vrt, Item_
   
8.   Dim Conn As Object, re As Object, dict As Object
   
9.   Dim strConn As String, SQL As String, s As String
   
10.   
    
11.   Set Conn = CreateObject("ADODB.Connection")
    
12.   Set dict = CreateObject("Scripting.Dictionary")
    
13.   Set re = CreateObject("VBScript.RegExp")
    
14.   re.Global = True
    
15.   re.Pattern = "(\D+)(\d+)(\D+)(\d+)"
    
16.   
    
17.   ar = Split("I3:I4 C3 C5 I5:I6 A9 E9 C9 I9 C16:C17 E16:E17 C18:C19 E18:E19 C20:C21 E20:E21 C22:C23 E22:E23 C27:M27 C28:M28 C30:M30 C33:M33")
    
18.   For Each Item_ In ar
    
19.     For Each cel In Range(Item_)
    
20.       s = cel.Address(, , xlR1C1)
    
21.       For j = 4 To 2 Step -2
    
22.         br(-CInt(j = 2)) = re.Replace(s, "$" & j) - 1
    
23.       Next
    
24.       dict.Add Join(br, "|"), dict.Count + 2
    
25.     Next
    
26.   Next
    
27.   ReDim results(1 To 2345, 1 To dict.Count + 1)
    
28.   Set re = Nothing
    
29.   
    
30.   ActiveSheet.UsedRange.Offset(3).Clear 'Contents
    
31.   Application.ScreenUpdating = False
    
32.   
    
33.   s = "Excel 12.0;HDR=NO;IMEX=1;Database="
    
34.   If Application.Version < 12 Or InStr(Application.Path, "WPS") > 0 Then
    
35.     s = Replace(s, "12.0", "8.0")
    
36.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO';Data Source="
    
37.   Else
    
38.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source="
    
39.   End If
    
40.   Conn.Open strConn & Files_(LBound(Files_))
    
41.   
    
42.   SQL = "SELECT * FROM [" & s & "[.File]].[$A1:M40]"
    
43.   For j = LBound(Files_) To UBound(Files_)
    
44.     If Files_(j) <> ThisWorkbook.FullName Then
    
45.       cnt = cnt + 1
    
46.       results(cnt, 1) = cnt
    
47.       ar = Conn.Execute(Replace(SQL, "[.File]", Files_(j))).GetRows
    
48.       For Each Item_ In dict.Keys
    
49.         vrt = Split(Item_, "|")
    
50.         results(cnt, dict(Item_)) = ar(vrt(0), vrt(1))
    
51.       Next
    
52.     End If
    
53.   Next
    
54.   
    
55.   Range("A4").Resize(cnt, UBound(results, 2)) = results
    
56.   With Range("A1").CurrentRegion
    
57.     With Intersect(.Offset(0), .Offset(3))
    
58.       .Borders.LineStyle = xlContinuous
    
59.       .HorizontalAlignment = xlCenter
    
60.       .Font.Size = 9
    
61.     End With
    
62.   End With
    
63.   
    
64.   Conn.Close
    
65.   Set Conn = Nothing
    
66.   Set dict = Nothing
    
67.   Application.ScreenUpdating = True
    
68.   Beep
    
69. End Sub
    
70. 
    
71. Function GetFileName(Files_, Path_ As String, ext As String) As Boolean
    
72.   Dim File_ As String, j As Long, k As Long, ar(9999) As String
    
73.   If Right(Path_, 1) <> "\" Then Path_ = Path_ & "\"
    
74.   Do
    
75.     File_ = Dir(Path_, vbDirectory)
    
76.     Do
    
77.       If File_ <> "." And File_ <> ".." Then
    
78.         If (GetAttr(Path_ & File_) And vbDirectory) = vbDirectory Then
    
79.           k = k + 1
    
80.           ar(k) = Path_ & File_ & "\"
    
81.         Else
    
82.           If LCase(Right(File_, Len(ext))) = LCase(ext) Then '限于目前的.xls格式 可改灵活
    
83.             j = j + 1
    
84.             ReDim Preserve Files_(1 To j)
    
85.             Files_(j) = Path_ & File_
    
86.           End If
    
87.         End If
    
88.       End If
    
89.       File_ = Dir
    
90.     Loop While Len(File_)
    
91.     If k = 0 Then Exit Do
    
92.     Path_ = ar(k)
    
93.     k = k - 1
    
94.   Loop
    
95.   GetFileName = CBool(j)
    
96. End Function

复制代码

baofa2

纯SQL练习审核中附件测试.zip (149.13 KB, 下载次数: 12)

2024-5-1 08:13 上传

点击文件名下载附件

limonet

ykcbf1100 发表于 2024-5-1 07:03
用SQL还真无法处理这题的数据，因为要一个单元格一个单元格的提取，而且数量很多。

题目是获取文件。