CODEWITHSUNDEEP
vbaexcel
tenvfa
tenvfa

Reputation: 67

How to Merge Adjacent Columns With Same Data In Excel?

I found this macro to merge adjacent rows. I want to edit it to merge adjacent columns instead of rows.

The original macro (from the link above) produces the result on the left. My edited macro produces the result on the right.

enter image description here

I tried switching all references of row/col in the code, but it is only merging the columns after the second or third occurrence. Is something wrong with my loop?

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

Upvotes: 0

Views: 1807

Answers (1)

user4039065
user4039065

Reputation:

Here's an alternate that might make more sense. I'll leave the merged cell formatting up to you.

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

Upvotes: 2

Related Questions