[已解决]如何可以用VBA合并单元格，和拆分单元格。谢谢。

新一

如何可以用VBA合并单元格，和拆分单元格，如附件，A列，B列，F列，G列，进行合并，如“合并单元格表”。合并后也可以取消合并，如“取消合并单元格表”。谢谢。

最佳答案

月排行榜 / 总排行榜

这儿有肥猫

2014-9-9 21:00

   c

跳转到最佳答案楼层

这儿有肥猫

以第二个工作表第一列为例

1. Sub 合并单元格()
   
2. Application.DisplayAlerts = False
   
3. Dim i&, j&
   
4. i = Sheets("取消合并单元格").Cells(Rows.Count, 1).End(3).Row
   
5. For j = i To 5 Step -1
   
6.     If Cells(j, 1) = Cells(j - 1, 1) Then
   
7.        Range(Cells(j, 1), Cells(j - 1, 1)).Merge
   
8.     End If
   
9. Next
   
10. Application.DisplayAlerts = True
    
11. End Sub
    
12. Sub 取消合并()
    
13. Application.DisplayAlerts = False
    
14. Dim i&, j&
    
15. Dim StrMer As String, s&
    
16. i = Sheets("取消合并单元格").Cells(Rows.Count, 1).End(3).Row
    
17. With Sheets("取消合并单元格")
    
18. For j = 5 To i
    
19.     StrMer = .Cells(j, 1).Value
    
20.     s = .Cells(j, 1).MergeArea.Count
    
21.     .Cells(j, 1).UnMerge
    
22.     .Range(.Cells(j, 1), .Cells(j + s - 1, 1)).Value = StrMer
    
23.     j = j + s - 1
    
24. Next
    
25. End With
    
26. Application.DisplayAlerts = True
    
27. End Sub
    

复制代码

这儿有肥猫

ccc

新一

这儿有肥猫 发表于 2014-9-9 20:16
ccc

谢谢老师。但代码运行后，只有A列有变化，其他三列没变化。

su45

这儿有肥猫 发表于 2014-9-9 20:16
ccc

你可能要改下代码，你可能没考虑12行的现象

这儿有肥猫

1. Sub 合并单元格()
   
2. Application.ScreenUpdating = False
   
3. Application.DisplayAlerts = False
   
4. Dim i&, j&, s&
   
5. i = Sheets("取消合并单元格").Cells(Rows.Count, 3).End(3).Row
   
6. For j = i To 5 Step -1
   
7.     If Cells(j, 2) = Cells(j - 1, 2) Then
   
8.        Range(Cells(j, 2), Cells(j - 1, 2)).Merge
   
9.     End If
   
10. Next
    
11. 
    
12. 
    
13. Range("B5:B" & i).Copy
    
14. Range("A5:A" & i).PasteSpecial Paste:=xlPasteFormats
    
15. Application.CutCopyMode = False
    
16. 
    
17. i = Sheets("取消合并单元格").Cells(Rows.Count, 8).End(3).Row
    
18. 
    
19. For j = i To 5 Step -1
    
20.     If Cells(j, 7) = Cells(j - 1, 7) Then
    
21.        Range(Cells(j, 7), Cells(j - 1, 7)).Merge
    
22.     End If
    
23. Next
    
24. 
    
25. 
    
26. Range("g5:g" & i).Copy
    
27. Range("f5:f" & i).PasteSpecial Paste:=xlPasteFormats
    
28. Application.CutCopyMode = False
    
29. 
    
30. Application.DisplayAlerts = True
    
31. Application.ScreenUpdating = True
    
32. 
    
33. End Sub
    
34. Sub 取消合并()
    
35. Application.ScreenUpdating = False
    
36. Application.DisplayAlerts = False
    
37. Dim i&, j&, m&, StrMer, s&
    
38. i = Sheets("取消合并单元格").Cells(Rows.Count, 3).End(3).Row
    
39. With Sheets("取消合并单元格")
    
40.      For m = 1 To 2
    
41.          For j = 5 To i
    
42.              StrMer = .Cells(j, m).Value
    
43.              s = .Cells(j, m).MergeArea.Count
    
44.             .Cells(j, m).UnMerge
    
45.             .Range(.Cells(j, m), .Cells(j + s - 1, m)).Value = StrMer
    
46.             j = j + s - 1
    
47.          Next
    
48.      Next
    
49. End With
    
50. 
    
51. i = Sheets("取消合并单元格").Cells(Rows.Count, 8).End(3).Row
    
52. With Sheets("取消合并单元格")
    
53.      For m = 6 To 7
    
54.          For j = 5 To i
    
55.              StrMer = .Cells(j, m).Value
    
56.              s = .Cells(j, m).MergeArea.Count
    
57.             .Cells(j, m).UnMerge
    
58.             .Range(.Cells(j, m), .Cells(j + s - 1, m)).Value = StrMer
    
59.             j = j + s - 1
    
60.          Next
    
61.      Next
    
62. End With
    
63. 
    
64. 
    
65. 
    
66. Application.DisplayAlerts = True
    
67. Application.ScreenUpdating = True
    
68. 
    
69. 
    
70. End Sub
    

复制代码

这儿有肥猫

   c

新一

谢谢老师{:011:}

dsmch

1. Private Sub CommandButton1_Click()
   
2. If CommandButton1.Caption = "合并单元格" Then
   
3.     Call hb
   
4.     CommandButton1.Caption = "取消合并单元格"
   
5. Else
   
6.     Call qx
   
7.     CommandButton1.Caption = "合并单元格"
   
8. End If
   
9. End Sub
   
10. Sub hb()
    
11. Application.ScreenUpdating = False
    
12. Application.DisplayAlerts = False
    
13. s = 5
    
14. For i = 6 To Range("a65536").End(xlUp).Row + 1
    
15.     zf = Cells(i, 1) & "," & Cells(i, 2)
    
16.     zf2 = Cells(i - 1, 1) & "," & Cells(i - 1, 2)
    
17.     If zf <> zf2 Then
    
18.         Range(Cells(s, 1), Cells(i - 1, 1)).Merge
    
19.         Range(Cells(s, 2), Cells(i - 1, 2)).Merge
    
20.         s = i
    
21.     End If
    
22. Next
    
23. Application.DisplayAlerts = True
    
24. Application.ScreenUpdating = True
    
25. End Sub
    
26. Sub qx()
    
27. Range("a1").CurrentRegion.UnMerge
    
28. For i = 6 To Range("c65536").End(xlUp).Row
    
29.     If Cells(i, 1) = "" Then Cells(i, 1) = Cells(i - 1, 1): Cells(i, 2) = Cells(i - 1, 2)
    
30. Next
    
31. End Sub

复制代码

dsmch

以a-b列为例