[已解决]谁能帮我用写以下程序啊？大哥求你了

jeffljh

我每次做休假台账（sheet1）的时候，都必须在备注栏位手工录入休假类型，我想编写一个VBA程序，每次打开的时候，自动实现以下功能：比如以Albert（第3行）为例，在G3“年休假”一栏录入4后，程序自动在备注栏填写上“年休假“；再比如像Tony（第9-10行）请了两次假，一次是年休假，一次是事假，程序在备注栏自动合并单元格（M9和M10），然后再自动填写上“年休假&事假”；再比如Pont（第5-6行）也是休了两次假，两次都是病假和年休假，程序自动在备注栏合并单元格（M5和M6），然后自动填充上去掉重复的一项，即不填充“病假&年休假&病假&年休假”而是去掉重复的，只填充“病假&年休假”
PS：这个表有500个人，我只截取了其中一部分，远远没有显示完。
如果能实现前两项就感激不尽了，如果第三项也能实现，那我们就喝血酒拜兄弟吧

最佳答案

月排行榜 / 总排行榜

zjdh

2013-7-6 18:38

1. Sub test()
   
2.     Dim I%, J%, K%, N%
   
3.     Range("Q3:Q65536").ClearContents
   
4.     For I = 3 To Range("M65536").End(3).Row
   
5.         Set D = CreateObject("scripting.dictionary")
   
6.         If Cells(I, "Q").MergeCells Then N = Cells(I, "Q").MergeArea.Count - 1 Else N = 0
   
7.         For J = 0 To N
   
8.             For K = 4 To 12
   
9.                 If Trim(Cells(I + J, K)) <> "" Then D(Cells(2, K).Value) = ""
   
10.             Next
    
11.         Next
    
12.         Cells(I, "Q") = Join(D.KEYS, "&")
    
13.         I = I + N
    
14.     Next
    
15. End Sub
    

复制代码

TEST.rar (11.71 KB, 下载次数: 5)

2013-7-6 18:38 上传

点击文件名下载附件

跳转到最佳答案楼层

1091126096

你截个图干什么？表格还让别人为你做，你要传附件上来，并详细说明要求。

殿堂之上

顶2楼

zjdh

没有附件怎么让人帮你？？！！

jb_008

翠花，上附件              

jeffljh

jb_008 发表于 2013-7-4 08:55
翠花，上附件

已经上附件了，麻烦你了

jeffljh

zjdh 发表于 2013-7-4 08:10
没有附件怎么让人帮你？？！！

已经上附件了，麻烦你了

jeffljh

1091126096 发表于 2013-7-3 22:20
你截个图干什么？表格还让别人为你做，你要传附件上来，并详细说明要求。

已经上附件了，麻烦你了

adders

个人建议,类似这种表格,能不用合并单元格就不要用,EXCEL和VBA对合并单元格的操作使用上有诸多的不便.

当然就按照你现有的表格及要求,也不难做到,以下是代码,代码后是附件(打开文件后点"Test"按钮就可以测试)

1. Sub test()
   
2. Const FRow = 3
   
3. Dim LRow As Long, n As Long
   
4. Dim sBZ As String
   
5. LRow = Cells(Rows.Count, "M").End(xlUp).Row
   
6. Application.ScreenUpdating = False
   
7. Range(Cells(FRow, "Q"), Cells(LRow, "Q")).ClearContents
   
8. i = FRow
   
9. Do While i <= LRow
   
10.     If Cells(i, "Q").MergeCells Then n = Cells(i, "Q").MergeArea.Count Else n = 1
    
11.     For j = 4 To 12
    
12.         If Len(Trim(Cells(i, j))) + Len(Trim(Cells(i + n - 1, j))) > 0 Then
    
13.           If sBZ = "" Then
    
14.               sBZ = Cells(FRow - 1, j).Value
    
15.           Else
    
16.               sBZ = sBZ & "&" & Cells(FRow - 1, j).Value
    
17.           End If
    
18.               Cells(i, "Q") = sBZ
    
19.         End If
    
20.     Next i  
    
21.     sBZ = ""
    
22.     i = i + n
    
23. Loop
    
24. Application.ScreenUpdating = True
    
25. End Sub

复制代码

1. Sub test2()   '如有超过2行合并的情况,请用以下代码. 对应附后文件: "合并单元格休假.xls"
   
2. Const FRow as Byte = 3
   
3. Dim LRow As Long, n As Long, i As Long, j As Long
   
4. Dim sBZ As String
   
5. LRow = Cells(Rows.Count, "M").End(xlUp).Row
   
6. Application.ScreenUpdating = False
   
7. Range(Cells(FRow, "Q"), Cells(LRow, "Q")).ClearContents
   
8. i = FRow
   
9. Do While i <= LRow
   
10.     If Cells(i, "Q").MergeCells Then n = Cells(i, "Q").MergeArea.Count Else n = 1
    
11.     For j = 4 To 12
    
12.         If WorksheetFunction.CountA(Range(Cells(i, j), Cells(i + n - 1, j))) > 0 Then
    
13.             If sBZ = "" Then
    
14.                 sBZ = Cells(FRow - 1, j).Value
    
15.             Else
    
16.                 sBZ = sBZ & "&" & Cells(FRow - 1, j).Value
    
17.             End If
    
18.                 Cells(i, "Q") = sBZ
    
19.         End If
    
20.     Next j
    
21.     sBZ = ""
    
22.     i = i + n
    
23. Loop
    
24. Application.ScreenUpdating = True
    
25. End Sub

复制代码

zjdh

1. Sub test()
   
2.     Dim I%, J%, K%, N%
   
3.     Range("Q3:Q65536").ClearContents
   
4.     For I = 3 To Range("M65536").End(3).Row
   
5.         Set D = CreateObject("scripting.dictionary")
   
6.         If Cells(I, "Q").MergeCells Then N = Cells(I, "Q").MergeArea.Count - 1 Else N = 0
   
7.         For J = 0 To N
   
8.             For K = 4 To 12
   
9.                 If Trim(Cells(I + J, K)) <> "" Then D(Cells(2, K).Value) = ""
   
10.             Next
    
11.         Next
    
12.         Cells(I, "Q") = Join(D.KEYS, "&")
    
13.         I = I + N
    
14.     Next
    
15. End Sub
    

复制代码

TEST.rar (11.71 KB, 下载次数: 5)

2013-7-6 18:38 上传

点击文件名下载附件