全自动智能分表和合表

baofa2

参与，现成的简单修改

仅供测试.zip (38.66 KB, 下载次数: 32)

2024-5-21 16:51 上传

点击文件名下载附件

李筱龙

baofa2 发表于 2024-5-21 16:19

非常感谢！我看不懂，但复制到VBA里执行拆分表可以用，谢谢！

ykcbf1100

工作簿合并和工作簿拆分都写了。

附件供参考。。。

ykcbf1100

按乡镇拆分代码。。。

1. Sub 按乡镇拆分()   '//2024.5.21
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim t: t = Timer
   
5.     Dim d As Object, rng As Range
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set ws = ThisWorkbook
   
8.     p = ThisWorkbook.Path & ""
   
9.     For Each sht In ws.Sheets
   
10.         arr = sht.UsedRange
    
11.         For i = 5 To UBound(arr)
    
12.             s = Trim(arr(i, 2))
    
13.             If s <> "" Then
    
14.                 d(s) = ""
    
15.             End If
    
16.         Next i
    
17.     Next sht
    
18.     For Each k In d.keys
    
19.         ws.Sheets.Copy
    
20.         Set wb = ActiveWorkbook
    
21.         For Each sht In Sheets
    
22.             m = 0
    
23.             With sht
    
24.                 arr = .UsedRange
    
25.                 .DrawingObjects.Delete
    
26.                 For i = 5 To UBound(arr)
    
27.                     If Trim(arr(i, 2)) = k Then
    
28.                         m = m + 1
    
29.                     Else
    
30.                         If rng Is Nothing Then
    
31.                             Set rng = .Rows(i)
    
32.                         Else
    
33.                             Set rng = Union(rng, .Rows(i))
    
34.                         End If
    
35.                     End If
    
36.                 Next i
    
37.                 If m = 0 Then
    
38.                     .UsedRange.Offset(5).Clear
    
39.                     .[a5].Resize(1, 2) = ""
    
40.                     .[c5] = "无"
    
41.                 Else
    
42.                     If Not rng Is Nothing Then rng.Delete
    
43.                 End If
    
44.                 Set rng = Nothing
    
45.             End With
    
46.         Next
    
47.         wb.SaveAs p & k
    
48.         wb.Close
    
49.     Next k
    
50.     Application.ScreenUpdating = True
    
51.     Application.DisplayAlerts = True
    
52.     MsgBox "拆分完毕，共用时： " & Format(Timer - t, "0.000秒"), , "提示"
    
53. End Sub
    
54. 
    

复制代码

李筱龙

3190496160 发表于 2024-5-21 16:26
Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant

谢谢！非常感谢，学习了。

李筱龙

ykcbf1100 发表于 2024-5-21 16:38
先写一个文件合并的代码吧，拆分的代码有时间再写。

非常感谢！学习了。

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set ww = ThisWorkbook
lj = ThisWorkbook.Path & "\拆分文件\"
For Each sh In Sheets
    mc = sh.Name
    r = sh.Cells(Rows.Count, 1).End(xlUp).Row
    y = sh.Cells(3, Columns.Count).End(xlToLeft).Column
    ar = sh.Range(sh.Cells(1, 1), sh.Cells(r, y))
    For i = 5 To UBound(ar)
        If ar(i, 2) <> "" Then
            If Not d.exists(ar(i, 2)) Then Set d(ar(i, 2)) = CreateObject("scripting.dictionary") ''乡镇
            If Not d(ar(i, 2)).exists(mc) Then Set d(ar(i, 2))(mc) = CreateObject("scripting.dictionary") ''乡镇和工作表名称
            d(ar(i, 2))(mc)(i) = i '''对应的数据行
        End If
    Next i
Next sh
For Each k In d.keys ''循环乡镇
    m = 0
    For Each kk In d(k).keys ''循环工作表
        m = m + 1
        If m = 1 Then
            ww.Sheets(kk).Copy
            Set wb = ActiveWorkbook
        Else
            ww.Sheets(kk).Copy after:=wb.Worksheets(wb.Worksheets.Count)
        End If
        With ww.Sheets(kk)
            r = .Cells(Rows.Count, 1).End(xlUp).Row
            y = .Cells(3, Columns.Count).End(xlToLeft).Column
            ar = .Range(.Cells(1, 1), .Cells(r, y))
        End With
        n = 0
        ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
        With wb.ActiveSheet
            .UsedRange.Offset(4).Borders.LineStyle = 0
            .UsedRange.Offset(4) = Empty
            For Each wk In d(k)(kk).keys ''循环乡镇下的工作表的所有行
                n = n + 1
                br(n, 1) = n
                For j = 2 To UBound(ar, 2)
                    br(n, j) = ar(wk, j)
                Next j
            Next wk
            .[a5].Resize(n, UBound(br, 2)) = br
            .[a5].Resize(n, UBound(br, 2)).Borders.LineStyle = 1
            For Each shp In .Shapes
                shp.Delete
            Next shp
        End With
    Next kk
    wb.SaveAs Filename:=lj & k & ".xlsx"
    wb.Close
Next k
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

拆分和汇总
测试.rar (65.85 KB, 下载次数: 42)

2024-5-22 11:18 上传

点击文件名下载附件

cai2532

这个实例很实用收藏了。

125675117

3190496160 发表于 2024-5-22 11:18
拆分和汇总

拆分1的结果在分薄里，拆分2的结果在哪里呢