自己写的合并单元格处理宏，请各位大侠提点意见

i3myself

最近因为工作关系，经常需要处理各种合并单元格的问题，自己用vba写了一个处理的宏，不过后来想起来搜了一下，好像很少有用两层for循环这种思路来写的，请问是我的思路有问题吗，还是这种做法会有什么效率上的问题，请各位提下意见。

1. Attribute VB_Name = "模块1"
   
2. Sub 当前列单元格合并拆分()
   
3. Attribute 当前列单元格合并拆分.VB_ProcData.VB_Invoke_Func = " \n14"
   
4. '
   
5. '当前列单元格合并拆分
   
6. '
   
7. '
   
8. Application.ScreenUpdating = False
   
9. Application.DisplayAlerts = False
   
10. crtcol = Selection.Column
    
11. colheight = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Row - 1
    
12. 'MsgBox IsEmpty(Cells(3461, 3))
    
13. userinput = CInt(InputBox("请选择功能:" & vbCrLf & "1为所在列相同单元格自动合并" & vbCrLf & "2为所在列空单元格向上合并" & vbCrLf & "3为所在列合并单元格拆分并填充" & vbCrLf & "4为所在列合并单元格拆分不填充", "功能选择"))
    
14. If userinput = 1 Then
    
15.     Call colMerge(crtcol, colheight)
    
16.     ElseIf userinput = 2 Then
    
17.     Call nullMerge(crtcol, colheight)
    
18.     ElseIf userinput = 3 Or userinput = 4 Then
    
19.     Call colUnMerge(crtcol, colheight, userinput)
    
20.     Else
    
21.     MsgBox "该模块尚未开发，敬请期待"
    
22. End If
    
23. Application.ScreenUpdating = True
    
24. Application.DisplayAlerts = True
    
25.     'MsgBox crtcol
    
26.     'Call colUnMerge(crtcol, colheight)
    
27.     'Call colMerge(crtcol, colheight)
    
28. End Sub
    
29. 
    
30. Private Sub colUnMerge(crtcol, colheight, userinput)
    
31. For i = 1 To colheight
    
32.     With Cells(i, crtcol).MergeArea
    
33.     'MsgBox .Address
    
34.     If (.Columns.Count = 1) And (.Rows.Count > 1) Then
    
35.     mgheight = .Rows.Count
    
36.     .UnMerge
    
37.     If userinput = 3 Then
    
38.     .Value = Cells(i, crtcol).Value
    
39.     End If
    
40.     i = i + mgheight - 1
    
41.     End If
    
42.     End With
    
43. Next
    
44. End Sub
    
45. 
    
46. Private Sub colMerge(crtcol, colheight)
    
47. 
    
48. For i = 1 To colheight
    
49.     'If i > 40 Then
    
50.     'MsgBox i
    
51.     'End If
    
52.     If Cells(i, crtcol).MergeCells Then
    
53.     i = i + Cells(i, crtcol).MergeArea.Rows.Count - 1
    
54.     ElseIf IsEmpty(Cells(i, crtcol)) Then
    
55.    
    
56.     Else
    
57.     j = i
    
58.     tmp = Cells(i, crtcol).Value
    
59.     Do
    
60.     j = j + 1
    
61.     Loop While (Cells(j, crtcol).Value = tmp) And (j <= colheight)
    
62.     j = j - 1
    
63.     If j > i Then
    
64.         Range(Cells(i, crtcol), Cells(j, crtcol)).Merge
    
65.     End If
    
66.     i = j
    
67.     End If
    
68. Next
    
69.     With Columns(crtcol)
    
70.         .HorizontalAlignment = xlCenter
    
71.         .VerticalAlignment = xlCenter
    
72.         .WrapText = False
    
73.     End With
    
74. End Sub
    
75. 
    
76. 
    
77. 
    
78. Private Sub nullMerge(crtcol, colheight)
    
79. For i = 1 To colheight
    
80.     'If i > 40 Then
    
81.     'MsgBox i
    
82.     'End If
    
83.     If Cells(i, crtcol).MergeCells Then
    
84.     i = i + Cells(i, crtcol).MergeArea.Rows.Count - 1
    
85.     Else
    
86.     j = i
    
87.     Do
    
88.         j = j + 1
    
89.     Loop While IsEmpty(Cells(j, crtcol)) And (j <= colheight)
    
90.     j = j - 1
    
91.     If j > i Then
    
92.         Range(Cells(i, crtcol), Cells(j, crtcol)).Merge
    
93.     End If
    
94.     i = j
    
95.     End If
    
96. Next
    
97.     With Columns(crtcol)
    
98.         .HorizontalAlignment = xlCenter
    
99.         .VerticalAlignment = xlCenter
    
100.         .WrapText = False
     
101.     End With
     
102. End Sub
     

复制代码

llllzh

拆分和合并单元格也能写出这么多代码

i3myself

llllzh 发表于 2021-12-28 15:29
拆分和合并单元格也能写出这么多代码

额，有四个功能，相同的合并，或者和下面的空白单元格合并，拆了，和拆了之后每个单元格都填上同样的内容

无雨谷

学习了，谢谢