如何将汇总工资表利用vba拆分成姓名命名的一个工作簿

格轩

急！希望大神帮忙解答，谢谢！

附件有4个人，怎么拆分成每个人一个工作簿，拆分成4个excel工作簿，某某某几月工资

chis3

格轩 发表于 2019-2-11 18:02
拆分表的格式要和主表一致，第一行工资支付表，第一行分类，大神看看能否改下，谢谢！

Sub test()
    Dim arr
    Dim brr
    Dim dic
    Dim i As Integer
    Dim item
    Set dic = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    brr = [a2:ar2]
    For i = 3 To UBound(arr)
        If Not dic.exists(arr(i, 5)) Then
            Set dic(arr(i, 5)) = Cells(i, 1).Resize(1, 44)
        Else
            Set dic(arr(i, 5)) = Union(dic(arr(i, 5)), Cells(i, 1).Resize(1, 44))
        End If
    Next i
    For Each item In dic.keys
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = item
        [a1] = "工資結算支付書"
        Range("a1:ar1").Merge
        [a2].Resize(1, UBound(brr, 2)) = brr
        dic(item).Copy [a3]
        Cells.HorizontalAlignment = xlCenter
    Next item
End Sub

這樣?

chxw68

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

复制代码

chxw68

下午刚写了个类似的。

microyip

论坛里有很多类似案例可以参考，尤其朱荣兴版主刚在除夕才发出几个样板代码，多去论坛搜索、学习，不要伸手等现成的。

chis3

Sub test()
    Dim arr
    Dim brr
    Dim dic
    Dim i As Integer
    Dim item
    Set dic = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    brr = [a2:ar2]
    For i = 3 To UBound(arr)
        If Not dic.exists(arr(i, 5)) Then
            Set dic(arr(i, 5)) = Cells(i, 1).Resize(1, 44)
        Else
            Set dic(arr(i, 5)) = Union(dic(arr(i, 5)), Cells(i, 1).Resize(1, 44))
        End If
    Next i
    For Each item In dic.keys
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = item
        [a1].Resize(1, UBound(brr, 2)) = brr
        dic(item).Copy [a2]
    Next item
End Sub

格轩

chis3 发表于 2019-2-11 17:57
Sub test()
    Dim arr
    Dim brr

拆分表的格式要和主表一致，第一行工资支付表，第一行分类，大神看看能否改下，谢谢！

格轩

chis3 发表于 2019-2-11 18:31
Sub test()
    Dim arr
    Dim brr

能拆分成按名字命名的工作簿吗？

chxw68

总共就4个人怎么拆分成8个工作簿呢？

格轩

chxw68 发表于 2019-2-12 15:06
总共就4个人怎么拆分成8个工作簿呢？

有多少人发工资就拆分成几个人，谢谢！

opiona

69楼：http://club.excelhome.net/thread-1409141-1-1.html