Excel VBA：合併循環內的範圍

Question

我想合併那章重複章只到一個單元格。

這是我的代碼如何循環。

 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

如果你知道然後你可以調整下面的代碼。我已經通過錄制宏創建了這個功能，然後根據需要禁用/啓用警報。我已經包含了一個函數來將整數列值轉換爲alph等值。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