如何在Excel中合并具有相同数据的相邻列？

Question

我发现this macro要合并相邻的行。我想对其进行编辑以合并相邻的列而不是行。

原始宏（来自上面的链接）在左侧产生结果。我编辑的宏会在右侧产生结果。

我尝试在代码中切换行/列的所有引用，但是它只是在第二次或第三次出现之后合并列。我的循环出问题了吗？

Sub MergeSimilarCol()
'Updateby20131127
Dim Rng As Range, xCell As Range
'Dim xRows As Integer
Dim xCols As Integer
xTitleId = "MergeSimilarCol"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'xRows = WorkRng.Rows.Count
xCols = WorkRng.Columns.Count

'For Each Rng In WorkRng.Columns
    'For i = 1 To xRows - 1
        'For j = i + 1 To xRows
            'If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
                'Exit For
             'End If
        'Next
        'WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge
        'i = j - 1
    'Next
'Next

For Each Rng In WorkRng.Rows
    For i = 1 To xCols - 1
        For j = i + 1 To xCols
            If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
                Exit For
            End If
        Next
        WorkRng.Parent.Range(Rng.Cells(1, i), Rng.Cells(1, j - 1)).Merge
        i = j - 1
    Next
Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Answer 1

这是一个更有意义的选择。我将把合并单元格的格式留给您。

Option Explicit

Sub mergeWeeks()
    Dim lc As Long, nc As Long, cr As Long, rng As Range

    Application.DisplayAlerts = False

    With Worksheets("sheet2")
        For cr = 1 To 2
            lc = Application.Match("zzz", .Rows(cr))
            Set rng = .Cells(cr, 1)
            Do While rng.Column < lc
                nc = Application.Match(rng.Value & "z", .Rows(cr))
                rng.Resize(1, nc - rng.Column + 1).Merge
                Set rng = rng.Offset(0, 1)
            Loop
        Next cr
    End With

    Application.DisplayAlerts = True

End Sub