两个合并单元格VBA之间的单元格范围

我有单元格D11到H11合并，D20到H20合并，D25到H25合并。 我们将调用合并的行部分。 所以D11到H11是第1部分，D20到H20是第2部分等。合并部分之间的行数可以变化。

我试图创build一个可以创build部分之间的单元格的垂直范围的VBA。 因此，例如，第1节和第2节之间的垂直范围是H12到H19，第2节到第3节之间的范围是H21到H24。

有任何想法吗？

我目前正在尝试创build一个数组1s和2s（2s意味着有一个合并的单元格），然后计数1s来尝试创build一个范围。 我不知道这是否会起作用，或者是否有更简单的方法来做到这一点。

Sub newGroup() Dim LastRow As Integer Dim i As Long Dim arr() 'This is an array definition i = 0 LastRow = Cells(Rows.Count, "H").End(xlUp).Row For i = 12 To LastRow + 1 If Cells(i, 8).MergeCells = True Then ReDim Preserve arr(1 To i) arr(i) = 2 Else: arr(i) = 1 End If Next End Sub 

Answer 1

你可以有一个函数返回一个范围内未合并值的数组。

如果你可以依靠列是相同的然后做到这一点：

1. 通过工作表行检查列8（H）上的每一行的合并值循环。
2. testing每行的.mergecells值为true或false。
3. find第一个合并单元格值为true。
4. 从这一点find下一个错误值，将其logging为取消合并范围中的第一行。
5. find下一个合并值，将前一行logging为最后一个合并行。

瞧，你有第一个范围。 如果你想这样做的所有值，它将它们存储到一个数组。

有点像这样：

（我在我的第一篇文章中对这个拙劣的代码感到内疚，所以我做了一个简化的版本，应该更容易理解和实现）

 Sub Test() Dim v() As Variant Dim wb As Workbook Dim ws As Worksheet Set wb = ThisWorkbook Set ws = wb.Sheets(1) ' assign worksheet you want to scan v = Get_Unmerged_Ranges(8, ws) ' Better version End Sub Function Get_Unmerged_Ranges(c As Integer, ws As Worksheet) As Variant Dim v() As Variant Dim r As Long ReDim v(1 To 1) With ws Do r = r + 1 If .Cells(r, c).MergeCells Then If Not IsEmpty(v(1)) Then ReDim Preserve v(1 To UBound(v) + 1) i = UBound(v) If i Mod 2 = 1 Then v(i) = r + 1 ' Odd entry is counted as start range which is 1 after the mergecells Else v(i) = r - 1 ' Even entry is counted as end range which is the 1 before the mergecells r = r - 1 ' Set the row back one to set the first variable on the next loop End If End If Loop Until r > .UsedRange.Rows.Count End With Get_Unmerged_Ranges = v End Function 

Answer 2

作为使用Range.Find方法的替代方法，它比逐个单元格循环要快得多。 它收集这些部分并将它们放入variablesrngSections中。 然后可以使用rngSections.Areas属性（代码中显示的示例）

 Sub tgr() Dim rngFound As Range Dim rngMerge As Range Dim rngSections As Range Dim SectionArea As Range Dim strFirst As String With Application.FindFormat .Clear .MergeCells = True End With Set rngFound = Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchFormat:=True) If Not rngFound Is Nothing Then strFirst = rngFound.Address Set rngMerge = rngFound Do Set rngFound = Cells.Find("*", rngFound, SearchFormat:=True) If rngFound.Address = strFirst Then Exit Do If rngFound.Row - rngMerge.Row > 1 Then Select Case (rngSections Is Nothing) Case True: Set rngSections = Range(rngMerge.Offset(1), rngFound.Offset(-1)) Case Else: Set rngSections = Union(rngSections, Range(rngMerge.Offset(1), rngFound.Offset(-1))) End Select End If Set rngMerge = rngFound Loop End If If Not rngSections Is Nothing Then 'Whatever you want to do with the sections 'For example, you could loop through them For Each SectionArea In rngSections.Areas MsgBox SectionArea.Address Next SectionArea End If End Sub 

Answer 3

您可能想要尝试循环使用列，并将每个新的未合并单元格添加到您的范围，如：

 Set r1 = Nothing Do Until Cells(row, 8).MergeCells = True If r1 Is Nothing Then Set r1 = Range(Cells(row, 8), Cells(row, 8)) Else Set r1 = Union(r1, Range(Cells(row, 8), Cells(row, 8))) End If row = row + 1 Loop 

然后提供与段一样多的范围variables。