求多个表格按姓名批量拆分后汇总在一个表格里面

焦糖木鱼

数据很多，要按人员分成各个表格，之前有找个是单个表格按人员折分成独立的表格
现在想要同一份里面多个表格按人员拆分后还是汇总在同个人名下。
下面这个是我之前找到的。

1. Sub CFGZB()
   
2.     Dim myRange As Variant
   
3.     Dim myArray
   
4.     Dim titleRange As Range
   
5.     Dim title As String
   
6.     Dim columnNum As Integer
   
7.     myRange = Application.InputBox(prompt:="请选择标题行：", Type:=8)
   
8.     myArray = WorksheetFunction.Transpose(myRange)
   
9.     Set titleRange = Application.InputBox(prompt:="请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”", Type:=8)
   
10.     title = titleRange.Value
    
11.     columnNum = titleRange.Column
    
12.     Application.ScreenUpdating = False
    
13.     Application.DisplayAlerts = False
    
14.     Dim i&, Myr&, Arr, num&
    
15.     Dim d, k
    
16.     For i = Sheets.Count To 1 Step -1
    
17.         If Sheets(i).Name <> "数据源" Then
    
18.             Sheets(i).Delete
    
19.         End If
    
20.     Next i
    
21.     Set d = CreateObject("Scripting.Dictionary")
    
22.     Myr = Worksheets("数据源").UsedRange.Rows.Count
    
23.     Arr = Worksheets("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum))
    
24.     For i = 1 To UBound(Arr)
    
25.         d(Arr(i, 1)) = ""
    
26.     Next
    
27.     k = d.keys
    
28.     For i = 0 To UBound(k)
    
29.         Set conn = CreateObject("adodb.connection")
    
30.         conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
    
31.         Sql = "select * from [数据源$] where " & title & " = '" & k(i) & "'"
    
32.         Dim Nowbook As Workbook
    
33.         Set Nowbook = Workbooks.Add
    
34.         With Nowbook
    
35.             With .Sheets(1)
    
36.                 .Name = k(i)
    
37.                 For num = 1 To UBound(myArray)
    
38.                     .Cells(1, num) = myArray(num, 1)
    
39.                 Next num
    
40.                 .Range("A2").CopyFromRecordset conn.Execute(Sql)
    
41.             End With
    
42.         End With
    
43.         ThisWorkbook.Activate
    
44.         Sheets(1).Cells.Select
    
45.         Selection.Copy
    
46.         Workbooks(Nowbook.Name).Activate
    
47.         ActiveSheet.Cells.Select
    
48.         Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    
49.                                SkipBlanks:=False, Transpose:=False
    
50.         Application.CutCopyMode = False
    
51.         Nowbook.SaveAs ThisWorkbook.Path & "" & k(i)
    
52.         Nowbook.Close True
    
53.         Set Nowbook = Nothing
    
54.     Next i
    
55.     conn.Close
    
56.     Set conn = Nothing
    
57.     Application.DisplayAlerts = True
    
58.     Application.ScreenUpdating = True
    
59. End Sub
    

复制代码

求解.zip (5.95 KB, 下载次数: 9)

2020-2-13 00:12 上传

点击文件名下载附件

3190496160

上传你真实的文件，特别是工作表名称要跟你实际的一样，不然，没法判断那些事需要拆分的工作表的

3190496160

代码只针对你上传的附件，需要拆分的工作表数为  3， 自己根据市情况修改代码
Sub chaifne()
Set d = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
    For Each sh In Sheets
        If sh.Index > 3 Then sh.Delete
    Next sh
Application.DisplayAlerts = True
    For Each sh In Sheets
        If sh.Index < 4 Then
            ar = sh.[a1].CurrentRegion
            For i = 2 To UBound(ar)
                If Trim(ar(i, 2)) <> "" Then
                    d(Trim(ar(i, 2))) = ""
                End If
            Next i
        End If
    Next sh
    For Each k In d.keys
        n = 0
        ReDim br(1 To 10000, 1 To UBound(ar, 2))
        For Each sh In Sheets
            If sh.Index < 4 Then
                ar = sh.[a1].CurrentRegion
                For i = 2 To UBound(ar)
                    If Trim(ar(i, 2)) = k Then
                        n = n + 1
                        For j = 1 To UBound(ar, 2)
                            br(n, j) = ar(i, j)
                        Next j
                    End If
                Next i
            End If
        Next sh
        Set sht = Worksheets.Add(after:=Sheets(Sheets.Count))
        sht.Name = k
        sht.[a1].Resize(1, UBound(ar, 2)) = ar
        sht.[a2].Resize(n, UBound(br, 2)) = br
    Next k
End Sub

3190496160

求解.rar (21.52 KB, 下载次数: 2)

2020-2-13 09:17 上传

点击文件名下载附件

焦糖木鱼

3190496160 发表于 2020-2-13 09:17

能点完后自动生成单个的表格，然后单个表格还是按123这样分开，不合并在一起吗
比如张二，单独个表格名字是张二，然后这个表格打开完，里面还是按123的这样分开各自的清单

3190496160

焦糖木鱼 发表于 2020-2-13 09:37
能点完后自动生成单个的表格，然后单个表格还是按123这样分开，不合并在一起吗
比如张二，单独个表格名 ...

呵呵呵，老兄，一开始就应该不你的真实意图说清楚的，你是需要一薄多表拆分为多薄多表吧，最好还是上传你真是的文件，

焦糖木鱼

不好意思啊，表达能力比较差

焦糖木鱼

我想下看怎么弄个表格，稍等下，因为公司的数据没办法直接发上来，不好意思

chxw68

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

复制代码

chxw68

前几天刚写过一个，供楼主参考吧。