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

这个怎么样？

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

Answer 3

如果您事先知道范围，那么您可以调整下面的代码。我通过录制宏然后根据需要禁用/启用警报来创建它。我已经包含了一个将整数列值转换为 alph 等效项的函数。MainLoop Intcol1 和 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