Question

我需要帮助来创建一个代码来合并第1列到第25列，然后是第30列到第40列的列中的五个单元格，然后循环向下行以再次合并五个单元格。

例如，我有一张包含A3到au3数据的工作表。这里我希望范围A3中的每个单元格：A7，B3：B7，C3：C7等等直到Y3：Y7应该合并然后保持原样Z3：AD3并且合并下一个范围从AE3：AE7到AN3： AN7。

然后循环行以再次合并五个单元格

我正在使用此代码，但它太复杂，工作速度很慢，无法正常工作＆＃34;对于wks＆＃34;

中的每个工作表

任何提示帮助...................

Sub mergecells()
Application.DisplayAlerts = False
Dim Wks As Worksheet
Dim i As Integer, j As Integer, x As Integer
On Error Resume Next
With Wks("Employee Data")
For each Worksheet In Wks
For i = 1 To 24

Range(Cells(3, i), Cells(7, i)).Merge
Range(Cells(8, i), Cells(12, i)).Merge
Range(Cells(13, i), Cells(17, i)).Merge
Range(Cells(18, i), Cells(22, i)).Merge
Range(Cells(23, i), Cells(27, i)).Merge
Range(Cells(28, i), Cells(32, i)).Merge
Range(Cells(33, i), Cells(37, i)).Merge
Range(Cells(38, i), Cells(42, i)).Merge
Range(Cells(43, i), Cells(47, i)).Merge
Range(Cells(48, i), Cells(52, i)).Merge
Range(Cells(53, i), Cells(57, i)).Merge
Range(Cells(58, i), Cells(62, i)).Merge
Range(Cells(63, i), Cells(67, i)).Merge
Range(Cells(68, i), Cells(72, i)).Merge
Range(Cells(73, i), Cells(77, i)).Merge
Range(Cells(78, i), Cells(82, i)).Merge
Range(Cells(83, i), Cells(87, i)).Merge
Range(Cells(88, i), Cells(92, i)).Merge
Range(Cells(93, i), Cells(97, i)).Merge
Range(Cells(98, i), Cells(102, i)).Merge

For j = 33 To 37

Range(Cells(3, j), Cells(7, j)).Merge
Range(Cells(8, j), Cells(12, j)).Merge
Range(Cells(13, j), Cells(17, j)).Merge
Range(Cells(18, j), Cells(22, j)).Merge
Range(Cells(23, j), Cells(27, j)).Merge
Range(Cells(28, j), Cells(32, j)).Merge
Range(Cells(33, j), Cells(37, j)).Merge
Range(Cells(38, j), Cells(42, j)).Merge
Range(Cells(43, j), Cells(47, j)).Merge
Range(Cells(48, j), Cells(52, j)).Merge
Range(Cells(53, j), Cells(57, j)).Merge
Range(Cells(58, j), Cells(62, j)).Merge
Range(Cells(63, j), Cells(67, j)).Merge
Range(Cells(68, j), Cells(72, j)).Merge
Range(Cells(73, j), Cells(77, j)).Merge
Range(Cells(78, j), Cells(82, j)).Merge
Range(Cells(83, j), Cells(87, j)).Merge
Range(Cells(88, j), Cells(92, j)).Merge
Range(Cells(93, j), Cells(97, j)).Merge
Range(Cells(98, j), Cells(102, j)).Merge

For x = 41 To 48

Range(Cells(3, x), Cells(7, x)).Merge
Range(Cells(8, x), Cells(12, x)).Merge
Range(Cells(13, x), Cells(17, x)).Merge
Range(Cells(18, x), Cells(22, x)).Merge
Range(Cells(23, x), Cells(27, x)).Merge
Range(Cells(28, x), Cells(32, x)).Merge
Range(Cells(33, x), Cells(37, x)).Merge
Range(Cells(38, x), Cells(42, x)).Merge
Range(Cells(43, x), Cells(47, x)).Merge
Range(Cells(48, x), Cells(52, x)).Merge
Range(Cells(53, x), Cells(57, x)).Merge
Range(Cells(58, x), Cells(62, x)).Merge
Range(Cells(63, x), Cells(67, x)).Merge
Range(Cells(68, x), Cells(72, x)).Merge
Range(Cells(73, x), Cells(77, x)).Merge
Range(Cells(78, x), Cells(82, x)).Merge
Range(Cells(83, x), Cells(87, x)).Merge
Range(Cells(88, x), Cells(92, x)).Merge
Range(Cells(93, x), Cells(97, x)).Merge
Range(Cells(98, x), Cells(102, x)).Merge

Next         
Next
Next
Next
Columns.VertxcalAlxgnment = xlVAlxgnCenter
Applxcatxon.DxsplayAlerts = True

End Sub

Answer 1

下面的代码将根据Worksheets("Employee Data")中的帖子合并范围，代码运行时间不到一秒。

Option Explicit

Sub MergeCells()

Dim ws As Worksheet
Dim lCol As Long, lRow As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False

For Each ws In ThisWorkbook.Worksheets
    With ws
        For lRow = 3 To 33 Step 5 ' you can increase beyond row 33
            For lCol = 1 To 25
                .Range(.Cells(lRow, lCol), .Cells(lRow + 4, lCol)).Merge
            Next lCol
            For lCol = 30 To 40
                .Range(.Cells(lRow, lCol), .Cells(lRow + 4, lCol)).Merge
            Next lCol
        Next lRow
    End With
Next ws
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

使用vba代码合并动态范围，然后循环

1 个答案: