VBA代码求助，求助各位大咖，不甚感激

hlgeng8695

各位老师，附件中，EXCEL“表1”是建立的文件发放台账明细，“表2”是要签字的文件发放记录，我要实现的功能是：“表1”中输入标黄单元格的相关信息，，此信息在“表2”中标黄的位置自动生成出来，每次生成单个文件的发放记录，（表2中，涉及合并单元格，跳过空白的单元格），谢谢老师的不吝赐教！

Chip_Kenny

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. Dim i%, s$
   
3. i = ActiveCell.Row: If i < 3 Then ActiveSheet.Buttons("CreateMe").Visible = False: Exit Sub
   
4. Ckbtn
   
5. With ActiveSheet.Buttons("CreateMe")
   
6.     If Cells(i, "b") = "" Then .Visible = False: Exit Sub
   
7.     .Visible = True
   
8.     .Top = Cells(i, "b").Top
   
9.     .Left = Cells(i, "b").Left
   
10.     .Width = Cells(i, "b").Width
    
11.     .Height = Cells(i, "b").Height
    
12.     .Caption = Cells(i, "b").Value
    
13. End With
    
14. End Sub
    

复制代码

1. Private Sub Ckbtn()
   
2. Dim cb As Boolean
   
3. With Sheets(1)
   
4.     j = .Buttons.Count
   
5.     For i = 1 To j
   
6.         If .Buttons(i).Name = "CreateMe" Then cb = True
   
7.     Next
   
8.     If Not cb Then
   
9.         Dim rng As Range
   
10.         Set rng = .Cells(2, "b")
    
11.         Set btn = .Buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
    
12.         With btn
    
13.             .Name = "CreateMe"
    
14.             .Caption = rng.Value
    
15.             .Characters.Font.Size = 9
    
16.             .OnAction = "zz"
    
17.         End With
    
18.         Set rng = Nothing
    
19.         Set btn = Nothing
    
20.     End If
    
21. End With
    
22. End Sub

复制代码

1. Private Sub zz()
   
2. Dim ar, i&, n%, s$, a
   
3. i = ActiveCell.Row
   
4. ar = Range("b" & i & ":aa" & i).Value
   
5. For j = 5 To UBound(ar, 2) - 2
   
6.     If Len(ar(1, j)) Then s = s & "|" & ar(1, j): n = n + 1
   
7. Next
   
8. a = Application.Transpose(Split(Mid(s, 2), "|"))
   
9. Sheets(2).Copy
   
10. For i = 1 To n
    
11.     Cells(5 + i, 1) = i
    
12. Next
    
13. [b6].Resize(1, 3) = ar
    
14. For j = 2 To 4
    
15.     Cells(6, j).Resize(n).Merge
    
16. Next
    
17. Cells(6, j).Resize(n) = a
    
18. End Sub

复制代码

高飞扬

Chip_Kenny 发表于 2018-9-28 09:56

谢谢老师的指导！

hlgeng8695

Chip_Kenny 发表于 2018-9-28 09:56

非常感谢您勒！

hlgeng8695

Chip_Kenny 发表于 2018-9-28 09:56

太强了，要的就是这效果，谢谢老师的不吝赐教。

高飞扬

文件发放记录 模拟结果.zip (54.25 KB, 下载次数: 0)

2018-9-28 17:01 上传

点击文件名下载附件

Chip_Kenny 发表于 2018-9-28 09:56

    在Chip_Kenny 老师的基础上，我做了一点土办法改进(先一个个点击生成9个工作表，然后再排序，排序这个也不整齐，10以后的会跑到前面，然后再改名）， 不知道怎么样能将下面问题改进一下：
   现在需要生成9个（或者更多）工作表需要从B3一个单元格的挨个点击到B11单元格，才能完成9个工作表，如果是50个工作表就要点击50次，怎么样能够一次点击全部生成并且能够将工作表的名称以C列对应单元格命名呢？ 求指点！

Chip_Kenny

1. Private Sub zz()
   
2. Dim ar, i&, n%, s$, a
   
3. Application.ScreenUpdating = 0
   
4. With Sheets(1)
   
5.     ar = .Range("b3:y" & .[b65536].End(3).Row).Value
   
6. End With
   
7. Sheets(2).Copy
   
8. For ii = 1 To UBound(ar)
   
9.     s = "": n = 0
   
10.     Sheets(1).Copy after:=Sheets(Sheets.Count)
    
11.     Sheets(Sheets.Count).Name = ii
    
12.     For j = 5 To UBound(ar, 2)
    
13.         If Len(ar(ii, j)) Then s = s & "|" & ar(ii, j): n = n + 1
    
14.     Next
    
15.     a = Application.Transpose(Split(Mid(s, 2), "|"))
    
16.     For i = 1 To n
    
17.         Cells(5 + i, 1) = i
    
18.     Next
    
19.     For j = 1 To 3
    
20.         Cells(6, j + 1) = ar(ii, j)
    
21.     Next
    
22.     For j = 2 To 4
    
23.         Cells(6, j).Resize(n).Merge
    
24.     Next
    
25.     Cells(6, j).Resize(n) = a
    
26. Next
    
27. Application.DisplayAlerts = 0: Sheets(1).Delete: Application.DisplayAlerts = 1
    
28. Application.ScreenUpdating = 1
    
29. End Sub

复制代码

高飞扬

再次学习了，感谢老师的帮助！老师的上一种方法也不错，第一次见，也值得学习！

hlgeng8695

感谢两位老师的帮助，受益匪浅！

mavin

应该是不胜感激，你的不甚感激是不怎么感激的意思。