ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
EH云课堂-专业的职场技能充电站 限时送,魔方网表将Excel变在线系统 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 355|回复: 15

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-2-11 17:18 | 显示全部楼层 |阅读模式
本帖最后由 格轩 于 2019-2-12 17:21 编辑

急!希望大神帮忙解答,谢谢!

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

工资表格式.rar

10 KB, 下载次数: 9

TA的精华主题

TA的得分主题

发表于 2019-2-11 18:31 | 显示全部楼层
格轩 发表于 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

這樣?

TA的精华主题

TA的得分主题

发表于 2019-2-12 22:37 | 显示全部楼层
  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

复制代码

评分

参与人数 1鲜花 +2 收起 理由
格轩 + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-2-12 22:38 | 显示全部楼层
下午刚写了个类似的。

工资表格式.rar

30.38 KB, 下载次数: 20

TA的精华主题

TA的得分主题

发表于 2019-2-11 17:35 | 显示全部楼层
论坛里有很多类似案例可以参考,尤其朱荣兴版主刚在除夕才发出几个样板代码,多去论坛搜索、学习,不要伸手等现成的。

TA的精华主题

TA的得分主题

发表于 2019-2-11 17:57 | 显示全部楼层
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

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-2-11 18:02 | 显示全部楼层
chis3 发表于 2019-2-11 17:57
Sub test()
    Dim arr
    Dim brr

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-2-12 10:13 | 显示全部楼层
chis3 发表于 2019-2-11 18:31
Sub test()
    Dim arr
    Dim brr

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

TA的精华主题

TA的得分主题

发表于 2019-2-12 15:06 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-2-12 17:22 | 显示全部楼层
chxw68 发表于 2019-2-12 15:06
总共就4个人怎么拆分成8个工作簿呢?

有多少人发工资就拆分成几个人,谢谢!

TA的精华主题

TA的得分主题

发表于 2019-2-12 22:00 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

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

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

GMT+8, 2019-4-20 15:07 , Processed in 0.104180 second(s), 20 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

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

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

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