在二表中取数生成新的多表

kxs5555

菜鸟请高手出手相助：我有一个工作薄，内有购买和发放记录（手工录入），我想通过这二个表格生成单独的礼品发放及库存表，如有新的购买和发放记录录入，可更新发放及库存表。先谢谢啦！

quqiyuan

参与一下，仅供参考。。。
当没有的时候，添加工作表，如果有工作表，在后面追加数据，然后从新排序，生成新的库存
删除工作表，就是把后面的删除，剩下前面3个，请注意

quqiyuan

代码如下。。。
Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    Set sh = Sheets("购买记录")
    Set sht = Sheets("发放记录")
    Set d = CreateObject("scripting.dictionary")
    Set dic = CreateObject("scripting.dictionary")
    Dim ssh As Worksheet
    brr = sh.[a1].CurrentRegion
    arr = sht.[a1].CurrentRegion
    For i = 3 To UBound(arr)
        If arr(i, 1) <> Empty Then
            For j = 6 To UBound(arr, 2) Step 2
                If arr(i, j) <> Empty Then
                    If Not d.exists(arr(i, j)) Then Set d(arr(i, j)) = CreateObject("scripting.dictionary")
                    s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5)
                    If Not d(arr(i, j)).exists(s) Then
                        d(arr(i, j))(s) = arr(i, j + 1)
                    Else
                        d(arr(i, j))(s) = d(arr(i, j))(s) + arr(i, j + 1)
                    End If
                End If
            Next
        End If
    Next
    For i = 2 To UBound(brr)
        If Not dic.exists(brr(i, 2)) Then Set dic(brr(i, 2)) = CreateObject("scripting.dictionary")
        dic(brr(i, 2))(brr(i, 1)) = brr(i, 4)
    Next
    For Each k In dic.keys
        n = 2
        On Error Resume Next
        Set ssh = Sheets(k)
        On Error GoTo 0
        If ssh Is Nothing Then
            With Sheets.Add(after:=Sheets(Sheets.Count))
                .Name = k
                .[a1].Resize(, 9).Merge
                .[a1] = k
                .[a2].Resize(, 9) = [{"日期","ID","客户名称","产品名称","金额","摘要","购买礼品数量","发放礼品数量","库存礼品数量"}]
                For Each kk In dic(k).keys
                    n = n + 1
                    .Cells(n, 1) = kk
                    .Cells(n, 6) = "购买"
                    .Cells(n, 7) = dic(k)(kk)
                Next
                For Each kkk In d(k).keys
                    Key = Split(kkk, "|")
                    If Key(0) > kk Then
                        n = n + 1
                        For i = 0 To 4
                            .Cells(n, i + 1) = Key(i)
                        Next
                        .Cells(n, 6) = "发放礼品"
                        .Cells(n, 8) = d(k)(kkk)
                    End If
                Next
                .Cells(3, 1).Resize(n, 9).Sort key1:=.Range("a3"), _
                    order1:=xlAscending, Header:=xlNo
                For i = 3 To .Cells(.Rows.Count, 1).End(3).Row
                    If .Cells(i, 9) = Empty Then
                        If .Cells(i, 6) = "购买" Then
                            If i = 3 Then .Cells(i, 9) = .Cells(i, 7) Else .Cells(i, 9) = .Cells(i, 7) + .Cells(i - 1, 9)
                        Else
                            .Cells(i, 9) = .Cells(i - 1, 9) - .Cells(i, 8)
                        End If
                    End If
                Next
                With .[a1].CurrentRegion
                    .Borders.LineStyle = 1
                    .HorizontalAlignment = xlCenter
                    .Columns.AutoFit
                End With
            End With
        Else
            With ssh
                n = .Cells(.Rows.Count, 1).End(3).Row
                For Each kk In dic(k).keys
                    n = n + 1
                    .Cells(n, 1) = kk
                    .Cells(n, 6) = "购买"
                    .Cells(n, 7) = dic(k)(kk)
                Next
                For Each kkk In d(k).keys
                    Key = Split(kkk, "|")
                    If Key(0) > kk Then
                        n = n + 1
                        For i = 0 To 4
                            .Cells(n, i + 1) = Key(i)
                        Next
                        .Cells(n, 6) = "发放礼品"
                        .Cells(n, 8) = d(k)(kkk)
                    End If
                Next
                .Cells(3, 1).Resize(n, 9).Sort key1:=.Range("a3"), _
                    order1:=xlAscending, Header:=xlNo
                For i = 3 To .Cells(.Rows.Count, 1).End(3).Row
                    If .Cells(i, 6) = "购买" Then
                        If i = 3 Then .Cells(i, 9) = .Cells(i, 7) Else .Cells(i, 9) = .Cells(i, 7) + .Cells(i - 1, 9)
                    Else
                        .Cells(i, 9) = .Cells(i - 1, 9) - .Cells(i, 8)
                    End If
                Next
                With .[a1].CurrentRegion
                    .Borders.LineStyle = 1
                    .HorizontalAlignment = xlCenter
                    .Columns.AutoFit
                End With
            End With
        End If
    Next
    Set d = Nothing
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

Private Sub CommandButton2_Click()
    Application.DisplayAlerts = False
    n = Sheets.Count
    For i = n To 4 Step -1
        Sheets(i).Delete
    Next
    Application.DisplayAlerts = True
    Beep
End Sub

kxs5555

quqiyuan 发表于 2024-9-27 22:59
参与一下，仅供参考。。。
当没有的时候，添加工作表，如果有工作表，在后面追加数据，然后从新排序，生成 ...

谢谢！但有个问题：每次点生成都会报424错，且新生成的表格，格式较乱。

kxs5555

quqiyuan 发表于 2024-9-27 22:59
参与一下，仅供参考。。。
当没有的时候，添加工作表，如果有工作表，在后面追加数据，然后从新排序，生成 ...

并如未清除，每点一次生成，就累加一条记录

quqiyuan

在我这运行的好好的，都不错，在你那怎么样我不知道，你写的东西简直让人摸不着头脑

kxs5555

不好意思，表达不清楚。
有个问题：如未点清除按钮，每点一次生成按钮，之前存在的记录就会累加。

quqiyuan

kxs5555 发表于 2024-9-28 08:40
不好意思，表达不清楚。
有个问题：如未点清除按钮，每点一次生成按钮，之前存在的记录就会累加。

我看你有写可以更新表格的，所以在后面可以追加数据到已经存在的工作表的。这种情况是应该是：你购买记录和发放记录两个表格的内容已经输出到分发的那几个工作表后就需要清空，后面增加的数据自然就放到后面去了，这个就是追加（叫更新也行）数据了，如果每次都是把那些工作表删除，重新生成，那在开头加上删除那些工作表的宏代码就行了，或者call CommandButton2_Click，自然就都是新的工作表，内容就是你现在需要的，这个看你怎么使用的问题。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set d1 = CreateObject("scripting.dictionary")
   
7.     With Worksheets("购买记录")
   
8.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.         arr = .Range("a2:d" & r)
   
10.         For i = 1 To UBound(arr)
    
11.             If Not d.exists(arr(i, 2)) Then
    
12.                 ReDim brr(1 To 1000, 1 To 9)
    
13.             Else
    
14.                 brr = d(arr(i, 2))
    
15.             End If
    
16.             d1(arr(i, 2)) = d1(arr(i, 2)) + 1
    
17.             m = d1(arr(i, 2))
    
18.             brr(m, 1) = arr(i, 1)
    
19.             brr(m, 6) = arr(i, 3)
    
20.             brr(m, 7) = arr(i, 4)
    
21.             d(arr(i, 2)) = brr
    
22.         Next
    
23.     End With
    
24.     With Worksheets("发放记录")
    
25.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
26.         c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    
27.         arr = .Range("a1").Resize(r, c)
    
28.         For i = 3 To UBound(arr)
    
29.             For j = 6 To UBound(arr, 2) Step 2
    
30.                 If Len(arr(i, j)) <> 0 Then
    
31.                     If Not d.exists(arr(i, j)) Then
    
32.                         ReDim brr(1 To 1000, 1 To 9)
    
33.                     Else
    
34.                         brr = d(arr(i, j))
    
35.                     End If
    
36.                     d1(arr(i, j)) = d1(arr(i, j)) + 1
    
37.                     m = d1(arr(i, j))
    
38.                     brr(m, 1) = arr(i, 1)
    
39.                     brr(m, 2) = arr(i, 2)
    
40.                     brr(m, 3) = arr(i, 3)
    
41.                     brr(m, 4) = arr(i, 4)
    
42.                     brr(m, 5) = arr(i, 5)
    
43.                     brr(m, 6) = arr(1, j)
    
44.                     brr(m, 8) = arr(i, j + 1)
    
45.                     d(arr(i, j)) = brr
    
46.                 End If
    
47.             Next
    
48.         Next
    
49.     End With
    
50.     For Each aa In d.keys
    
51.         On Error Resume Next
    
52.         Set ws = Worksheets(aa)
    
53.         If Err Then
    
54.             Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
55.             ws.Name = aa
    
56.         End If
    
57.         On Error GoTo 0
    
58.         With ws
    
59.             .Cells.Clear
    
60.             With .Range("a1")
    
61.                 .Value = aa
    
62.                 .Resize(1, 9).Merge
    
63.             End With
    
64.             .Range("a2:i2") = Array("日期", "ID", "客户名称", "产品名称", "金额", "摘要", "购买礼品数量", "发放礼品数量", "库存礼品数量")
    
65.             .Range("a3").Resize(d1(aa), 9) = d(aa)
    
66.             .Range("a3").Resize(d1(aa), 9).Sort key1:=.Range("a3"), order1:=xlAscending, Header:=xlNo
    
67.             arr = .Range("a3").Resize(d1(aa), 9)
    
68.             arr(1, 9) = arr(1, 7) - arr(1, 8)
    
69.             For i = 2 To UBound(arr)
    
70.                 arr(i, 9) = arr(i - 1, 9) + arr(i, 7) - arr(i, 8)
    
71.             Next
    
72.             .Range("a3").Resize(d1(aa), 9) = arr
    
73.             With .Range("a2").Resize(1 + d1(aa), 9)
    
74.                 .Borders.LineStyle = xlContinuous
    
75.                 With .Font
    
76.                     .Name = "微软雅黑"
    
77.                     .Size = 11
    
78.                 End With
    
79.             End With
    
80.             .Columns(1).Resize(, 9).AutoFit
    
81.             With .UsedRange
    
82.                 .HorizontalAlignment = xlCenter
    
83.                 .VerticalAlignment = xlCenter
    
84.             End With
    
85.         End With
    
86.     Next
    
87.             
    
88.         
    
89. End Sub
    

复制代码

chxw68

参与一下。