Excel VBA: Einen Bereich innerhalb einer Schleife verschmelzen

Question

Ich möchte diese wiederholenden Kapitel in nur einer Zelle nach Kapitel zusammenführen.

Hier ist, wie mein Code die Schleife macht.

 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 

Ich habe versucht, es wie dieses

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

Aber es verschmilzt alle sich wiederholenden Kapitel in einer Zelle statt

Erwartetes Ergebnis Fusion:

Answer 1

Meine Methode ist unten

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 

Answer 2

Wenn Sie das wissen, Bereiche vor der Hand dann könnten Sie den Code unten einstellen. Ich habe dies erstellt, indem ich ein Makro aufgenommen habe und Warnungen dann je nach Bedarf deaktiviert/aktiviert habe. Ich habe eine Funktion enthalten, um Integer-Spaltenwerte in Alph-Äquivalente zu konvertieren. Die MainLoopIntcol1 und intcol2 wären Werte, die Sie basierend auf der Eingabe aus dem ursprünglichen Formular bereitstellen würden.

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 

Answer 3

Wie wäre es damit?

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