Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 5086|回复: 10

[已解决]求!求!改代码

[复制链接]
发表于 2014-5-14 15:10 | 显示全部楼层 |阅读模式
本帖最后由 文轩馨婷 于 2014-5-15 15:55 编辑

之前对于这个表有发过贴,虽有解决方法但没达到最终我想要的,现在次求助帮忙修改代码,当然如果有好的方法也行!

要求:(如附件)
   1.选择部门——点击按钮自动生成输入部门的工资表如何达到——最终效果(红色阴影表);如"103质检部"表如何变成“质检”表,即多增加两列(一前一后)序列号并且各部门数据一生成就会紧接着最后一条数据自动合计人数/天数/加班小时等
    2.当已生成某某工资表中对应资料库的数据有更改或变动时,也会弹出提示窗口“已生成的某某工资表资料库数据有变动,别忘了重新生成”
   3.资料库中某些单元格有批注,自动生成后依然存在

希望改好的代码也帮忙注释中文解释


望各位不吝赐教!!!
最佳答案
2014-5-15 13:21
资料库里有批注的没弄过来。其实也是有办法的,不过懒得弄了。

如何自动生成工资表2.zip

167.35 KB, 下载次数: 14

 楼主| 发表于 2014-5-14 18:02 | 显示全部楼层
不曾看见有回复!

自己帮自己顶一下!
回复

使用道具 举报

 楼主| 发表于 2014-5-15 12:39 | 显示全部楼层
{:251:}{:251:}{:251:}还是没人关顾!!
回复

使用道具 举报

发表于 2014-5-15 13:19 | 显示全部楼层
  1. Sub 自动生成工资表()
  2.     arr = Sheet1.[a1].CurrentRegion '把资料库 的A列到AE列的数据 赋值给数组Arr1
  3.     Set d = CreateObject("scripting.dictionary")
  4.     For I = 2 To UBound(arr)
  5.         d(arr(I, 1)) = d(arr(I, 1)) & "," & I  '把不同部门对应的行放入字典
  6.     Next
  7.     bm = ActiveSheet.[c2]   '部门名称
  8.     shname = Mid(bm, 4, 2)  '根据部门名称确定需要生成的工作表名称(部门第四个字符开始,取2位)
  9.     On Error Resume Next
  10.     Application.DisplayAlerts = False
  11.     Sheets(shname).Delete   '如果已存在同名工作表,则删除
  12.     Application.DisplayAlerts = True
  13.     On Error GoTo 0
  14.     ActiveSheet.Copy after:=Sheets(Sheets.Count)
  15.     With ActiveSheet
  16.          .Name = shname
  17.         .Shapes.Range(Array("Button 1")).Delete  '把 工作表的按钮删除
  18.         xrr = Split(d(bm), ","): r = UBound(xrr)
  19.         ReDim brr(1 To r, 1 To 32)  '数组brr存放所要填充的内容
  20.         For J = 1 To r
  21.             k = Val(xrr(J))   '表示部门的各行
  22.             brr(J, 1) = J: brr(J, UBound(brr, 2)) = J   '第1列和最后1列:序号
  23.             For m = 2 To 29
  24.                 brr(J, m) = arr(k, m)
  25.             Next
  26.         Next
  27.         .[a4].Resize(UBound(brr), UBound(brr, 2)) = brr
  28.         .Cells(4 + r, 1) = "合计(" & r & "人)"
  29.         .Cells(4 + r, 1).Resize(1, 2).Merge
  30.         .Cells(4 + r, 4).Resize(1, 24).Formula = "=sum(r4c:r[-1]c)"   '加最后一行公式
  31.         .Range("a3").Resize(r + 2, 32).Borders.LineStyle = 1   '加边框
  32.          .Range("a4").Resize(r + 1, 32).ShrinkToFit = True   '缩小字体填充
  33.     End With
  34. End Sub

复制代码
回复

使用道具 举报

发表于 2014-5-15 13:20 | 显示全部楼层
在资料库里的提示代码:
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     mr = [a65536].End(3).Row  '最大行
  3.     If Target.Row = 1 Or Target.Row > mr Then Exit Sub   '如果发生改变的单元格行数不在数据区域,则结束
  4.     Set d = CreateObject("scripting.dictionary")
  5.     For Each sh In Worksheets
  6.         d(sh.Name) = ""   '把所有的工作表名称存入字典
  7.     Next
  8.     r = Target.Row   '当前行
  9.     bm = Cells(r, 1)   '部门名称
  10.     shname = Mid(bm, 4, 2)   '相对应的工作表名称
  11.     If d.exists(shname) Then   '如果工作表存在,则显示相应提示
  12.         xname = Cells(r, 3)
  13.         MsgBox "已生成的" & Mid(bm, 4) & xname & "工资表资料库数据有变动,别忘了重新生成"
  14.     End If
  15.    
  16. End Sub
复制代码
回复

使用道具 举报

发表于 2014-5-15 13:21 | 显示全部楼层    本楼为最佳答案   
资料库里有批注的没弄过来。其实也是有办法的,不过懒得弄了。

如何自动生成工资表2.rar

56.08 KB, 下载次数: 5

回复

使用道具 举报

 楼主| 发表于 2014-5-15 15:53 | 显示全部楼层
grf1973 发表于 2014-5-15 13:21
资料库里有批注的没弄过来。其实也是有办法的,不过懒得弄了。

十分感谢!!果断给最佳!

虽没来得及具体的测试,但应该可行!!

谢谢!


如果可以的话,麻烦帮忙把批注问题也解决一下{:251:}!
回复

使用道具 举报

发表于 2014-5-15 16:16 | 显示全部楼层
考虑批注问题,那只能用复制的办法把源数据复制过来。代码修改如下。
  1. Sub 自动生成工资表()
  2.     arr = Sheet1.[a1].CurrentRegion '把资料库 的A列到AE列的数据 赋值给数组Arr1
  3.     Dim CopyRng As Range
  4.     bm = ActiveSheet.[c2]   '部门名称
  5.     shname = Mid(bm, 4, 2)  '根据部门名称确定需要生成的工作表名称(部门第四个字符开始,取2位)
  6.     On Error Resume Next
  7.     Application.DisplayAlerts = False
  8.     Sheets(shname).Delete   '如果已存在同名工作表,则删除
  9.     Application.DisplayAlerts = True
  10.     On Error GoTo 0
  11.     ActiveSheet.Copy after:=Sheets(Sheets.Count)
  12.    
  13.     With ActiveSheet
  14.          .Name = shname
  15.         .Shapes.Range(Array("Button 1")).Delete  '把 工作表的按钮删除
  16.         For i = 2 To UBound(arr)
  17.             If arr(i, 1) = bm Then  '筛选出指定部门,存入CopyRng
  18.                 r = r + 1
  19.                 If CopyRng Is Nothing Then
  20.                     Set CopyRng = Sheet1.Cells(i, 2).Resize(1, 28)
  21.                 Else
  22.                     Set CopyRng = Union(CopyRng, Sheet1.Cells(i, 2).Resize(1, 28))
  23.                 End If
  24.                 .Cells(r + 3, 1) = r: .Cells(r + 3, 32) = r '第1列和最后1列:序号
  25.             End If
  26.         Next
  27.         If Not CopyRng Is Nothing Then
  28.             CopyRng.Copy .[b4]
  29.             .Cells(4 + r, 1) = "合计(" & r & "人)"
  30.             .Cells(4 + r, 1).Resize(1, 2).Merge
  31.             .Cells(4 + r, 4).Resize(1, 24).Formula = "=sum(r4c:r[-1]c)"   '加最后一行公式
  32.             .Range("a3").Resize(r + 2, 32).Borders.LineStyle = 1   '加边框
  33.             .Range("a4").Resize(r + 1, 32).ShrinkToFit = True   '缩小字体填充
  34.             .Range("a4").Resize(r + 1, 32).Value = .Range("a4").Resize(r + 1, 32).Value   '去公式
  35.         End If
  36.     End With
  37. End Sub

复制代码
回复

使用道具 举报

发表于 2014-5-15 16:19 | 显示全部楼层
请看附件。

如何自动生成工资表2.rar

54.07 KB, 下载次数: 5

回复

使用道具 举报

 楼主| 发表于 2014-5-15 16:58 | 显示全部楼层
OK拉!

谢谢!

{:11:}
回复

使用道具 举报

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

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 14:42 , Processed in 0.424997 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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