通过VBA将数据拆分成工作簿

漫不经心14

每次盘点时需要将数据筛选后按管理单位分发，真的是太头痛了，无奈水平有限，只能用笨笨的方法，一个一个筛选。
求助各位大神，通过VBA将表中的数据按管理单位拆分出来，同一个管理单位生成一个表，形成新的EXCEL文件或直接新建sheet表格都可以。


如果生成的表格式与总表一样就更棒啦！

请各位大佬们帮帮忙，谢谢！

Excelhome112233

用CC办公助手插件拆分，插件下载网址：http://www.ccchome.vip/

3822

Sub 分表()
    Dim arr
    Dim r As Long
    Dim sh As Worksheet

    arr = Sheets("总表").UsedRange

    Dim i As Integer
    Dim j As Integer
    For i = 2 To UBound(arr)

        On Error GoTo line1:

        Set sh = Sheets(arr(i, 9))

            r = sh.Range("a" & sh.Rows.Count).End(xlUp).Row + 1

            For j = 1 To UBound(arr, 2)
                sh.Cells(r, j) = arr(i, j)
            Next j

        On Error GoTo 0

    Next i
    Exit Sub
line1:
    Sheets.Add , Sheets(Sheets.Count)

    ActiveSheet.Name = arr(i, 9)

    Sheets("总表").Range("a1:K1").Copy Sheets(arr(i, 9)).Range("a1")

    Resume

End Sub

gwjkkkkk

Option Explicit
Sub TEST()
    Dim ar, br$(), cr, i&, j&, r&, dic As Object, vKey, t#, wks As Worksheet
   
    DoApp False
    Set dic = CreateObject("Scripting.Dictionary")
    t = Timer
    ar = [A1].CurrentRegion
    For i = 2 To UBound(ar): dic(ar(i, 9)) = dic(ar(i, 9)) & "," & i: Next
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
    For j = 1 To UBound(ar, 2): br(1, j) = ar(1, j): Next
   
    With Workbooks.Add
         For Each vKey In dic.keys
             .Worksheets.Add after:=.Worksheets(.Worksheets.Count)
             r = 1
             With .ActiveSheet
                 .Name = vKey
                 cr = Split(dic(vKey), ",")
                 For i = 1 To UBound(cr)
                     r = r + 1
                     For j = 1 To UBound(ar, 2)
                         br(r, j) = ar(cr(i), j)
                     Next j
                 Next i
                 With .[A1].Resize(r, UBound(br, 2))
                     .Value = br
                    .HorizontalAlignment = xlCenter
                    .Borders.LineStyle = xlContinuous
                    .Font.Size = 10
                    .Rows(1).Font.Bold = True
                    .EntireColumn.AutoFit
                    .EntireRow.AutoFit
                 End With
             End With
         Next
         For Each wks In .Sheets
             If wks.Name Like "*Sheet*" Then wks.Delete
         Next
    End With
   
    Set dic = Nothing
    DoApp
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub
Function DoApp(Optional b As Boolean = True)
    With Application
        .ScreenUpdating = b
        .DisplayAlerts = b
        .Calculation = -b * 30 - 4135
    End With
End Function

fzxba

根据管理单位分表到工作薄.rar (33 KB, 下载次数: 19)

2023-3-7 17:53 上传

点击文件名下载附件

gwjkkkkk

请参考。。。

漫不经心14

gwjkkkkk 发表于 2023-3-7 17:55
请参考。。。

感谢大佬，运行速度棒棒的，完美解决问题。

漫不经心14

gwjkkkkk 发表于 2023-3-7 17:53
Option Explicit
Sub TEST()
    Dim ar, br$(), cr, i&, j&, r&, dic As Object, vKey, t#, wks As Work ...

弱弱的问一下，如果我想按备注信息分表，应该怎么更改变量值呢？

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long
Dim d As Object
Dim rn As Range
Set d = CreateObject("scripting.dictionary")
lh = InputBox("请输入拆分列的列号", "列号", "9")
If lh = "" Then End
hs = InputBox("请输入标题行数", "行数", "1")
If hs = "" Then End
Set sh = ThisWorkbook.Worksheets("总表")
With sh
    r = .Cells(Rows.Count, Val(lh)).End(xlUp).Row
    y = .Cells(1, Columns.Count).End(xlToLeft).Column
    If r < hs + 1 Then MsgBox "数据源为空！": End
    If Val(lh) > y Then MsgBox "输入的列号超出了数据的最大列": End
    ar = .Range(.Cells(1, Val(lh)), .Cells(r, Val(lh)))
End With
For i = Val(hs) + 1 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        d(Trim(ar(i, 1))) = ""
    End If
Next i
For Each k In d.keys
    sh.Copy
    Set wb = ActiveWorkbook
    With wb.Worksheets(1)
        .Name = k
        For i = Val(hs) + 1 To UBound(ar)
            If Trim(.Cells(i, Val(lh))) <> k Then
                If rn Is Nothing Then
                    Set rn = .Rows(i)
                Else
                    Set rn = Union(rn, .Rows(i))
                End If
            End If
        Next i
        For Each shp In .Shapes
            shp.Delete
        Next shp
    End With
    If Not rn Is Nothing Then rn.Delete
    Set rn = Nothing
    wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xlsx"
    wb.Close
Next k
Set d = Nothing
Set rn = Nothing
Application.ScreenUpdating = True
MsgBox "拆分完毕！"
End Sub

3190496160

根据管理单位分表到工作薄.rar (25.46 KB, 下载次数: 13)

2023-3-8 12:33 上传

点击文件名下载附件