ExcelHome技术论坛

 找回密码
 免费注册
QQ登录 只需一步,快速开始
   
高效办公必会的Office99uu优优 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! 国内首部Excel函数公式学习大典 职场充电黑科技, Office微99uu优优 免费下载Excel行业应用视频
300集Office 2010微99uu优优 Tableau-数据可视化工具 突破Excel限制,用活字格提高效率 12门Excel免费公开课任你学
你的Excel 201099uu优优学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 456|回复: 13
打印 上一主题 下一主题

[求助] VBA工资条制作

[复制链接]
TA的精华主题TA的得分主题
跳转到指定楼层
1
发表于 2017-8-13 11:22 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
工资条.zip (29.16 KB, 下载次数: 21)   3个月的工资条制作,对满足条件的实际工资汇总,代码密码910206 求大神帮忙,非常感谢!
分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏2 分享分享 有用有用 无用无用
TA的精华主题TA的得分主题
2
发表于 2017-8-13 11:35 | 只看该作者
TA的精华主题TA的得分主题
3
发表于 2017-8-13 11:56 | 只看该作者
改一下原代码:

Sub test() '字典法
    '设置工作表名
    Const sheetname = "sheet3"
    Const totalsheetname = "工资单"
    '捕获数据
    Dim r%, i%
    Dim arr, brr
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    With Worksheets(totalsheetname)
        r = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range("b1:b" & r)
        For i = 2 To UBound(arr)
            If Not d.exists(arr(i, 1)) Then
                Set d(arr(i, 1)) = .Cells(1, 1).Resize(1, 23)
            End If
            Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 23))
        Next
    End With
    '写入数据
    With Worksheets(sheetname)
        .UsedRange.ClearContents
        m = 1
        For Each aa In d.keys
            d(aa).Copy .Cells(m, 1)
            m = m + 5
            Cells(m - 1, "s") = "合计"
            Cells(m - 1, "t").FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)"
        Next
    End With
    MsgBox "制作完成"
End Sub

TA的精华主题TA的得分主题
4
发表于 2017-8-13 11:58 | 只看该作者
原代码写得不错,既能写出,自己也应能改吧。


工资条.rar (22.57 KB, 下载次数: 17)


TA的精华主题TA的得分主题
5
发表于 2017-8-13 12:01 | 只看该作者
修改好了。
工资条.rar 11.47 KB, 下载次数: 39

评分

参与人数 1鲜花 +2 收起 理由
王爱玲 + 2 感谢帮助
查看全部评分
TA的精华主题TA的得分主题
6
发表于 2017-8-13 12:06 | 只看该作者
3个月的工资条制作
工资条.rar 13.04 KB, 下载次数: 6
TA的精华主题TA的得分主题
7
发表于 2017-8-13 13:03 | 只看该作者
不用字典做一个。
  • Sub test()
  •   Dim r%, i%
  •   Dim arr(), brr
  •   With Worksheets(1)
  •     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  •     Set Rng = .Range("a1:w1")
  •     m = 0
  •     For i = 2 To r
  •       If .Cells(i, 2) <> .Cells(i - 1, 2) Then
  •         m = m + 1
  •         ReDim Preserve arr(1 To 2, 1 To m)
  •         arr(1, m) = i
  •         arr(2, m) = i
  •       Else
  •         arr(2, m) = i
  •       End If
  •     Next
  •     s = (UBound(arr, 2) - 1) * 5 + 2
  •     For j = UBound(arr, 2) To 2 Step -1
  •       .Range(.Cells(arr(1, j), 1), .Cells(arr(2, j), 23)).Cut .Cells(s, 1)
  •       Rng.Copy .Cells(s - 1, 1)
  •       .Cells(s + 3, "s") = "合计"
  •       .Cells(s + 3, "t").FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)"
  •       s = s - 5
  •     Next
  •     .Cells(5, "s") = "合计"
  •     .Cells(5, "t").FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)"
  • End With
  • End Sub
  • 复制代码
    TA的精华主题TA的得分主题
    8
    发表于 2017-8-13 13:04 | 只看该作者
    详见附件。
    工资条.rar 14.35 KB, 下载次数: 12

    评分

    参与人数 1鲜花 +2 收起 理由
    王爱玲 + 2 感谢帮助,之前也是你帮我弄的。么么哒
    查看全部评分
    TA的精华主题TA的得分主题
    9
     楼主| 发表于 2017-8-13 13:55 | 只看该作者 |楼主

    这个能不能在合计后面留出一行空白行,这样好裁剪工资条。
    TA的精华主题TA的得分主题
    10
    发表于 2017-8-13 14:25 | 只看该作者
    修改好了。
    工资条.rar 17.34 KB, 下载次数: 13
    您需要登录后才可以回帖 登录 | 免费注册
    本版积分规则
    关闭

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

    关注官方微信,每天坐享新鲜教程
    手机版|关于我们|联系我们|ExcelHome    GMT+8, 2017-12-12 02:48 , Processed in 1.094493 second(s), 25 queries , Gzip On.
    Powered by Discuz! X3.3 © 2001-2017 Wooffice Inc.
        沪公网安备 31011702000001号 沪ICP备11019229号 本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师
    快速回复 返回顶部 返回列表
    99uu优优