分拆表并提取拆表单元格数值

xing_chen

老师！有簿，需将其中12个月的表按空列拆分为2张表，且拆表1中的个人金额取拆表2的小计数。也就是说需要1拆，2是提分拆出的总额放到拆表1中。因为有12个月的分拆和12个月的提取，其动态跨度，使我望而却步。敬请老师赐教。谢谢

xing_chen

这里的难点是遍历，有大循环和小循环。太搞人了！

xing_chen

怎么到现在审核未过呀？

lushang2018

1. Sub 测试()  ''答题专用套路--by:学习使我快乐
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim i, j, k, m, n, arr, brr, crr, drr
   
5.     Dim sht As Worksheet, wbk As Workbook, rng As Range
   
6.     Dim dic As Object, key As String, keys, items
   
7.     Set dic = CreateObject("scripting.dictionary")
   
8.     For Each sht In ThisWorkbook.Worksheets
   
9.         If Len(sht.Name) < 3 Then
   
10.             Sheets.Add after:=sht
    
11.             ActiveSheet.Name = sht.Name & "拆1"
    
12.             Sheets.Add after:=Sheets(sht.Name & "拆1")
    
13.             ActiveSheet.Name = sht.Name & "拆2"
    
14.             sht.Range("A1:G1").Copy Sheets(sht.Name & "拆1").Range("A1")
    
15.             sht.Range("A1:G1").Copy Sheets(sht.Name & "拆2").Range("A1")
    
16.             arr = sht.Range("A1").CurrentRegion.Value
    
17.             Sheets(sht.Name & "拆1").Range("A2").Resize(100, 4) = 去重(arr)
    
18.             Sheets(sht.Name & "拆2").Range("A2").Resize(100, 4) = 汇总(arr)
    
19.         End If
    
20.     Next
    
21.     Application.ScreenUpdating = True
    
22.     Application.DisplayAlerts = True
    
23. End Sub

复制代码

lushang2018

1. Function 去重(arr)
   
2.     Dim i, j, k, brr
   
3.     Dim dic As Object, key As String, keys, Item, dicItems
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     ReDim brr(1 To 3)
   
6.     For i = 2 To UBound(arr)
   
7.         key = arr(i, 1)
   
8.         If Not dic.Exists(key) Then
   
9.             brr(1) = key
   
10.             brr(2) = arr(i, 3)
    
11.             brr(3) = arr(i, 4)
    
12.             dic(key) = brr
    
13.         Else
    
14.             brr = dic(key)
    
15.             brr(2) = brr(2) + arr(i, 3)
    
16.             brr(3) = brr(3) + arr(i, 4)
    
17.             dic(key) = brr
    
18.         End If
    
19.     Next
    
20.     keys = dic.keys
    
21.     ReDim crr(1 To 100, 1 To 4)
    
22.     For i = 1 To dic.Count
    
23.         key = keys(i - 1)
    
24.         brr = dic(key)
    
25.         crr(i, 1) = brr(1)
    
26.         crr(i, 3) = brr(2)
    
27.         crr(i, 4) = brr(3)
    
28.     Next
    
29.     去重 = crr
    
30. End Function
    
31. Function 汇总(arr)
    
32.     Dim i, j, k, brr, 累计, y, rng As Range
    
33.     ReDim brr(1 To 1000, 1 To 4)
    
34.     For i = 2 To UBound(arr)
    
35.         If arr(i, 1) = "个人" Then
    
36.             k = k + 1
    
37.             For j = 1 To 4
    
38.                 brr(k, j) = arr(i, j)
    
39.             Next
    
40.             累计 = 累计 + arr(i, 4)
    
41.         End If
    
42.         brr(k + 1, 2) = "小计"
    
43.         brr(k + 1, 4) = 累计
    
44.     Next
    
45.     汇总 = brr
    
46. End Function
    

复制代码

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim br(), cr()
Dim r As Long
Application.SheetsInNewWorkbook = 1
For Each sh In ThisWorkbook.Worksheets
    m = m + 1
    ar = sh.[a1].CurrentRegion
    n_1 = 0: n_2 = 0
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
    ReDim cr(1 To UBound(ar), 1 To UBound(ar, 2))
    For i = 2 To UBound(ar)
        If Trim(ar(i, 2)) = "" Then
            n_1 = n_1 + 1
            For j = 1 To UBound(ar, 2)
                br(n_1, j) = ar(i, j)
            Next j
        Else
            n_2 = n_2 + 1
            For j = 1 To UBound(ar, 2)
                cr(n_2, j) = ar(i, j)
            Next j
        End If
    Next i
    If n_2 > 0 Then
        n_1 = n_1 + 1
        br(n_1, 1) = "个人"
        For j = 3 To 5
            br(n_1, j) = Application.Sum(Application.Index(cr, 0, j))
        Next j
    End If
    If n_1 > 0 Then
        If m = 1 Then
            Set wb = Workbooks.Add
            With wb.Worksheets(1)
                .Name = sh.Name & "拆1"
                .[a1].Resize(1, UBound(ar, 2)) = ar
                .[a2].Resize(n_1, UBound(br, 2)) = br
                .[a2].Resize(n_1, UBound(br, 2)).Borders.LineStyle = 1
            End With
        Else
            Set sht = Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count))
            With wb.ActiveSheet
                .Name = sh.Name & "拆1"
                .[a1].Resize(1, UBound(ar, 2)) = ar
                .[a2].Resize(n_1, UBound(br, 2)) = br
                .[a2].Resize(n_1, UBound(br, 2)).Borders.LineStyle = 1
            End With
        End If
        If n_2 > 0 Then
            Set sht = Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count))
            With wb.ActiveSheet
                .Name = sh.Name & "拆2"
                .[a1].Resize(1, UBound(ar, 2)) = ar
                .[a2].Resize(n_2, UBound(br, 2)) = cr
                .[a2].Resize(n_2, UBound(br, 2)).Borders.LineStyle = 1
            End With
        End If
    End If
Next sh
wb.SaveAs Filename:=ThisWorkbook.Path & "\拆分结果" & Format(Date, "yyyymmdd") & ".xlsx"
wb.Close
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

分拆表.rar (29.57 KB, 下载次数: 11)

2023-2-4 10:24 上传

点击文件名下载附件

3190496160

代码只是针对上传附件，为你提供一个解决问题的思路，仅供参考，

xing_chen

lushang2018 发表于 2023-2-4 09:04

谢谢老师！运行如愿！哎，依我水平只能囫囵吞枣，不求甚解了。谢谢

xing_chen

3190496160 发表于 2023-2-4 10:25
代码只是针对上传附件，为你提供一个解决问题的思路，仅供参考，

谢谢老师！运行如愿.老师代码，我只能慢慢理解。谢谢