Excel VBA：合并循环内的范围

我想把章节中的重复章节合并成一个单元格。

这是我的代码如何循环。

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

我的方法是波纹pipe

  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

如果你事先知道范围，那么你可以调整下面的代码。 我已经创build了这个通过录制一个macros，然后适当禁用/启用警报。 我已经包含了一个函数来将整数列值转换为等价的Intcol1和intcol2将是您将提供基于原始窗体的input提供的值。

 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