ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 469|回复: 16

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-2-13 00:16 | 显示全部楼层 |阅读模式
本帖最后由 焦糖木鱼 于 2020-2-13 00:18 编辑

数据很多,要按人员分成各个表格,之前有找个是单个表格按人员折分成独立的表格
现在想要同一份里面多个表格按人员拆分后还是汇总在同个人名下。
下面这个是我之前找到的。
  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
复制代码




微信图片_20200213001009.png 求解.zip (5.95 KB, 下载次数: 6)
微信图片_20200213001003.png

TA的精华主题

TA的得分主题

发表于 2020-2-13 09:07 | 显示全部楼层
上传你真实的文件,特别是工作表名称要跟你实际的一样,不然,没法判断那些事需要拆分的工作表的

TA的精华主题

TA的得分主题

发表于 2020-2-13 09:16 | 显示全部楼层
代码只针对你上传的附件,需要拆分的工作表数为  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

TA的精华主题

TA的得分主题

发表于 2020-2-13 09:17 | 显示全部楼层
求解.rar (21.52 KB, 下载次数: 1)

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-2-13 09:37 | 显示全部楼层

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

TA的精华主题

TA的得分主题

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

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-2-13 09:59 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-2-13 10:02 | 显示全部楼层
我想下看怎么弄个表格,稍等下,因为公司的数据没办法直接发上来,不好意思

TA的精华主题

TA的得分主题

发表于 2020-2-13 10:26 | 显示全部楼层

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

评分

参与人数 1鲜花 +2 收起 理由
3190496160 + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-2-13 10:27 | 显示全部楼层
前几天刚写过一个,供楼主参考吧。

求解.rar

19.07 KB, 下载次数: 11

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-10-1 09:38 , Processed in 0.101511 second(s), 15 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2021 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表