收款总表根据不同收款方式提取到另一个工作表

195520889

看案例，在销售总表中输入各个订单的付款情况后，自动会在后面的分表里面根据不同的付款方式自动汇总到对应的表格，谢谢各位大神，Excel小白，多多支持！

195520889

主要为了省去每次再复制粘贴到后面的工作表，谢谢大神们

kuangben8

这不就是拆分工作表吗？
Sub 拆分工作表()
    Dim Sht As Worksheet
    Dim arr, m&, n%, Str
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Application.DisplayAlerts = False
    For Each Sht In ThisWorkbook.Worksheets
        If Sht.Name <> "销售总表" Then
            Sht.Delete
        End If
    Next
    Application.DisplayAlerts = True
    With Worksheets("销售总表")
        arr = .Range("A1").CurrentRegion
        For m = 2 To UBound(arr, 1)
            If Not dic.Exists(arr(m, 7)) Then
                Set dic(arr(m, 7)) = .Range("A1:I1")
            End If
            Set dic(arr(m, 7)) = Union(dic(arr(m, 7)), .Range("A" & m & ":I" & m))    '写在此处才能完整的记录所有数据
        Next
    End With
    Application.ScreenUpdating = False
    For Each Str In dic.keys
        With Worksheets.Add(After:=Worksheets(Sheets.Count))
            .Name = Str
            dic(Str).Copy .Range("A1")
        End With
    Next
    Worksheets("销售总表").Activate
    Application.ScreenUpdating = True
End Sub

kuangben8

参考。：
案例.zip (21.46 KB, 下载次数: 21)

2020-11-19 19:51 上传

点击文件名下载附件

195520889

kuangben8 发表于 2020-11-19 19:51
参考。：

但这样的话，表2,3,4 都不能有任何其他的编辑咯？因为一运行宏就自动算一遍了

zpy2

195520889 发表于 2020-11-21 10:28
但这样的话，表2,3,4 都不能有任何其他的编辑咯？因为一运行宏就自动算一遍了

需要什么编辑的？啥意思？

kuangben8

195520889 发表于 2020-11-21 10:28
但这样的话，表2,3,4 都不能有任何其他的编辑咯？因为一运行宏就自动算一遍了

1. Sub 拆分工作表()
   
2.     Dim Sht As Worksheet
   
3.     Dim arr, m&, n%, Str
   
4.     Dim dic As Object
   
5.     Set dic = CreateObject("Scripting.Dictionary")
   
6.     With Worksheets("销售总表")
   
7.         arr = .Range("A1").CurrentRegion
   
8.         For m = 2 To UBound(arr, 1)
   
9.             If Not dic.Exists(arr(m, 7)) Then
   
10.                 Set dic(arr(m, 7)) = .Range("A1:I1")
    
11.             End If
    
12.             Set dic(arr(m, 7)) = Union(dic(arr(m, 7)), .Range("A" & m & ":I" & m))    '写在此处才能完整的记录所有数据
    
13.         Next
    
14.     End With
    
15.     Application.ScreenUpdating = False
    
16.     For Each Str In dic.keys
    
17.         On Error Resume Next
    
18.         Set Sht = Worksheets(Str)
    
19.         If Sht Is Nothing Then
    
20.             With Worksheets.Add(After:=Worksheets(Sheets.Count))
    
21.                 .Name = Str
    
22.                 dic(Str).Copy .Range("A1")
    
23.             End With
    
24.         Else
    
25.             dic(Str).Copy Sht.Range("A1")
    
26.         End If
    
27.         Set Sht = Nothing
    
28.     Next
    
29.     Worksheets("销售总表").Activate
    
30.     Application.ScreenUpdating = True
    
31. End Sub

复制代码

kuangben8

修改一下代码就好了。
案例.zip (21.46 KB, 下载次数: 22)

2020-11-21 13:36 上传

点击文件名下载附件

195520889

kuangben8 发表于 2020-11-21 13:36
修改一下代码就好了。

大神，你加我好友，有求于你