同一文件夹下依次打开工作簿选择指定内容新建文件夹及工作簿

limonet

Sub limonet()
    Dim Arr() As Variant, i%, j%, Cn As Object, StrSQL$, Path$, Brr As Variant, F As Object
    Path = ThisWorkbook.Path & "\"
    Set Cn = CreateObject("Adodb.Connection")
    Set Rst = CreateObject("Adodb.recordset")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    For Each F In CreateObject("scripting.filesystemobject").getfolder(ThisWorkbook.Path & "\数据").Files
        i = i + 1
        ReDim Preserve Arr(1 To 2, 1 To i): Arr(1, i) = F.Path: Arr(2, i) = F.Name
        StrSQL = StrSQL & " Union All Select * From [Excel 12.0;DataBase=" & Arr(1, i) & "].[财政补贴资金公开公示表格模板$A2:I]"
    Next F
    Brr = Application.Transpose(Application.Transpose(Cn.Execute("Select Distinct [镇（街道）名称] From (" & Mid(StrSQL, 12) & ")").GetRows))
    For j = 1 To UBound(Brr)
        MkDir Path & Brr(j)
        For i = 1 To UBound(Arr, 2)
            Cn.Close: StrSQL = "Select * Into Shee1 From [Excel 12.0;DataBase=" & Arr(1, i) & "].[财政补贴资金公开公示表格模板$A2:I] Where [镇（街道）名称]='" & Brr(j) & "'"
            Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 XML;Data Source=" & Path & Brr(j) & "\" & Arr(2, i)
            Cn.Execute (StrSQL)
        Next i
    Next j
End Sub

baofa2

借题参与练习.zip (84.9 KB, 下载次数: 7)

2024-5-20 12:29 上传

点击文件名下载附件

ykcbf1100

纯练习，字典，速度上比SQL法要慢一点。

ykcbf1100

纯练习。。。

1. Sub ykcbf()  '//2024.5.21   按镇拆分文件
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Dim tm: tm = Timer
   
7.     p = ThisWorkbook.Path & ""
   
8.     p1 = p & "数据"
   
9.     For Each f In fso.GetFolder(p1).Files
   
10.         If f.Name Like "*.xls*" Then
    
11.             d.RemoveAll
    
12.             fn = fso.GetBaseName(f)
    
13.             Set wb = Workbooks.Open(f, 0)
    
14.             arr = wb.Sheets(1).UsedRange
    
15.             For i = 3 To UBound(arr)
    
16.                 s = arr(i, 8)
    
17.                 d(s) = ""
    
18.             Next
    
19.             For Each k In d.keys
    
20.                 p2 = p & k & "数据"
    
21.                 If Not fso.FolderExists(p2) Then fso.CreateFolder p2
    
22.                 m = 0
    
23.                 ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
24.                 For i = 3 To UBound(arr)
    
25.                     If arr(i, 8) = k Then
    
26.                         m = m + 1
    
27.                         For j = 1 To UBound(arr, 2)
    
28.                             brr(m, j) = arr(i, j)
    
29.                         Next
    
30.                     End If
    
31.                 Next
    
32.                 wb.Sheets(1).Copy
    
33.                 Set wb1 = ActiveWorkbook
    
34.                 With wb1.Sheets(1)
    
35.                     .AutoFilterMode = False
    
36.                     .UsedRange.Offset(2 + m).Clear
    
37.                     .Columns(2).NumberFormatLocal = "@"
    
38.                     .[a3].Resize(m, UBound(arr, 2)) = brr
    
39.                 End With
    
40.                 wb1.SaveAs p2 & k & fn
    
41.                 wb1.Close
    
42.             Next
    
43.             wb.Close False
    
44.         End If
    
45.     Next f
    
46.     Application.ScreenUpdating = True
    
47.     Application.DisplayAlerts = True
    
48.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
49. End Sub
    

复制代码