Excel VBA：ループ内の範囲をマージする

Question

チャプターを1つのセルにマージする必要があります。

私のコードがどのようにループしているかは次のとおりです。

 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 

私はこの

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

のようにそれをマージしようとしました。しかし、それは一つのセルの代わりに

期待される結果にすべての繰り返しの章をマージします：あなたが知っている場合

Answer 1

私の方法は、あなたが期待される出力の例を提供することができ

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

手前で範囲を調整すれば、以下のコードを調整することができます。私は、マクロを記録し、適切なアラートを無効/有効にすることでこれを作成しました。整数列の値を英数字に変換する関数を追加しました。MainLoopIntcol1およびintcol2は、元のフォームからの入力に基づいて指定する値になります。

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

これはいかがですか？

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