CODEWITHSUNDEEP
vbaexcel
Hydes Yase
Hydes Yase

Reputation: 65

Excel VBA: Merging a range inside a loop

enter image description here I want to merge that repeating Chapters into just one cell by Chapter.

Here is how my code does the looping. 

        Dim label As Control
        Dim itm As Object
        For ctr = 1 To InfoForm.Chapter.ListCount - 1
            For Each label In InfoForm.Controls
                If TypeName(label) = "Label" Then
                    With ActiveSheet
                        i = i + 1

                        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + IIf(i = 1, 1, 0)
                        lastColumn = .Cells(i, .Columns.Count).End(xlToLeft).Column

                        If label <> "Chapter" Then
                            .Cells(lastColumn, i).Value = "Chapter " & ctr

                            .Cells(lastRow, i).Value = label.Caption
                        End If
                    End With
                End If
            Next
        Next

I've tried merging it like this

.Range(Cells(1, lastColumn), Cells(1,i)).Merge

But it merges all the repeating chapters into one cell instead

Expected Result: enter image description here

Upvotes: 0

Views: 272

Answers (3)

Dy.Lee
Dy.Lee

Reputation: 7567

My method is bellow

   Dim label As Control
    Dim itm As Object
    For ctr = 1 To InfoForm.Chapter.ListCount - 1
        For Each label In InfoForm.Controls
            If TypeName(label) = "Label" Then
                With ActiveSheet
                    i = i + 1

                    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + IIf(i = 1, 1, 0)
                    lastColumn = .Cells(i, .Columns.Count).End(xlToLeft).Column

                    If label <> "Chapter" Then
                        .Cells(lastColumn, i).Value = "Chapter " & ctr

                        .Cells(lastRow, i).Value = label.Caption
                    End If
                End With
            End If
        Next
    Next

    'this is merge method
    Dim rngDB As Range, rng As Range, n As Integer

    Application.DisplayAlerts = False
    Set rngDB = Range("a1", Cells(1, Columns.Count).End(xlToLeft))
    For Each rng In rngDB
        If rng <> "" Then
            n = WorksheetFunction.CountIf(rngDB, rng)
            rng.Resize(1, n).Merge
            rng.HorizontalAlignment = xlCenter
        End If
    Next rng
    Application.DisplayAlerts = True

Upvotes: 1

MiguelH
MiguelH

Reputation: 1425

If you know the ranges before hand then you could adjust the code below. I've created this by recording a macro and then disabling/enabling alerts as appropriate. I've included a function to convert integer column values to alph equivalents.The MainLoop Intcol1 and intcol2 would be values that you would provide based on the input from the original Form.

Sub MainLoop()
 Dim StrMycol_1 As String
 Dim StrMycol_2 As String
 Dim intcol1 As Integer
 Dim intcol2 As Integer

  intcol1 = 5: intcol2 = 7

  StrMycol_1 = WColNm(intcol1) ' mycell.column is numeric. Function returns integer
  StrMycol_2 = WColNm(intcol2) ' mycell.column is numeric. Function returns integer
'
  do_merge_centre StrMycol_1, StrMycol_2
End Sub

Sub do_merge_centre(col1, col2)
Range(col1 + "1:" + col2 + "1").Select
Application.DisplayAlerts = False
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
Application.DisplayAlerts = True
End Sub
'
Public Function WColNm(ColNum) As String
    WColNm = Split(Cells(1, ColNum).Address, "$")(1)
End Function

Upvotes: 0

Wils Mils
Wils Mils

Reputation: 633

How about this?

With ActiveSheet
  firstCol = 1
  lastCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
  For i = 1 To lastCol
    If .Cells(1, i) = "" Then GoTo NextCol 'skip blank cell

    If firstCol = 0 And .Cells(1, i) <> "" Then firstCol = i  'set first column

    If .Cells(1, i) = .Cells(1, i + 1) Then
        LastColDup = i  'remember last duplicate column
    Else
        Application.DisplayAlerts = False
        With .Range(Cells(1, firstCol), Cells(1, LastColDup + 1))
            .Merge
            .HorizontalAlignment = xlCenter
        End With
        Application.DisplayAlerts = True
        firstCol = 0
        LastColDup = 0
    End If
NextCol:
  Next i
End With

Upvotes: 0

Related Questions