拆分工作表,复制工作表,并保持原表格式

china047

数据.rar (11.92 KB, 下载次数: 96)

2018-8-21 14:49 上传

点击文件名下载附件

各位老师:

       附件数据工作薄中有一张"总表", 我想将总表按B列工厂拆分成单独的工作薄,并且要将数据工作薄中的"基础数据"表复制到拆分表中, 请各位老师帮忙看下能否用VBA解决 (注:拆分后的工作表格式要与原数据工作薄一样)
先谢过各位老师了!

苏小亓

EXCEL必备工具箱有这个功能，百度搜索EXCEL必备工具箱第一个就是。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim wb As Workbook
   
5.   Dim ws As Worksheet
   
6.   Dim mypath$, myname$
   
7.   Dim d As Object
   
8.   Application.ScreenUpdating = False
   
9.   Application.DisplayAlerts = False
   
10.   Set d = CreateObject("scripting.dictionary")
    
11.   With Worksheets("总表")
    
12.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
13.     arr = .Range("b1:b" & r)
    
14.     For i = 3 To UBound(arr)
    
15.       If Not d.exists(arr(i, 1)) Then
    
16.         Set d(arr(i, 1)) = .Range("a1:g2")
    
17.       End If
    
18.       Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 7))
    
19.     Next
    
20.   End With
    
21.   Application.SheetsInNewWorkbook = 1
    
22.   For Each aa In d.keys
    
23.     Set wb = Workbooks.Add
    
24.     With wb
    
25.       d(aa).Copy .Worksheets(1).Range("a1")
    
26.       .Worksheets(1).Name = "总表"
    
27.       ThisWorkbook.Worksheets("基础数据").Copy before:=.Worksheets(1)
    
28.       .SaveAs Filename:=ThisWorkbook.Path & "" & aa
    
29.       .Close False
    
30.     End With
    
31.   Next
    
32.   Application.ScreenUpdating = True
    
33.   MsgBox "数据拆分完毕！"
    
34. End Sub
    

复制代码

chxw68

详见附件。

everbest2015

典型的字典拆分

ykqrs

chxw68 发表于 2018-8-21 15:10

老师，好久不见，向你问好！
我记得你竞选版主了，没成功么？

chxw68

ykqrs 发表于 2018-8-21 15:39
老师，好久不见，向你问好！
我记得你竞选版主了，没成功么？

感谢你还记得我！一切都好！条件不够没竞选上。

lsc900707

Private Sub CommandButton1_Click()
    tms = Timer
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set d = CreateObject("Scripting.Dictionary")
    arr = Sheets("总表").UsedRange
    For i = 3 To UBound(arr)
        d(arr(i, 2)) = ""
    Next
    Application.SheetsInNewWorkbook = 2
    For Each k In d.keys
        Set ws = ThisWorkbook
        Set wb = Workbooks.Add
        ws.Sheets("总表").Cells.Copy wb.Worksheets(1).[a1]
        ws.Sheets("基础数据").Cells.Copy wb.Sheets(2).[a1]
        wb.Sheets(1).Name = "总表"
        wb.Sheets(2).Name = "基础数据"
        For Each sht In wb.Sheets
            For i = sht.UsedRange.Rows.Count To 3 Step -1
                If sht.Name = "总表" Then
                    If sht.Cells(i, 2) <> k Then
                        sht.Rows(i).Delete
                    End If
                End If
            Next
        Next
        wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k
        wb.Close False
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox Format(Timer - tms, "拆分完成，共耗时：0.00秒")
End Sub

lsc900707

附件供参考：