VBA：基于颜色索引的子范围无法正常工作，Couting appearances also not

Question

我更新了代码，因为它现在可以正确使用范围但一直冻结。有什么想法可以提高效率吗？

我创建了一个代码，它根据 colorindex 55 定义了主范围，并且效果很好。在这些范围内，我必须根据 colorindex 37 创建子范围。一个主范围内可以有多个子范围，因此子范围的名称应该是“main_range_name”和第一个子范围的“C1”，第二个子范围的 C2，第三个子范围的 C3 等. 不幸的是，代码只为每个主范围提供了一个子范围，最后只有一个 C。此外，子范围未正确分配给主范围，例如子范围“ABCD_C”给我一个主范围“WXYZ”的子范围。

这里是代码：

Sub Testbook1()

    Dim currentRangeStart As Long
    currentRangeStart = 1 'assuming data starts at row 2

    Dim currentClientName As String
    currentClientName = Replace(Cells(currentRangeStart, 1).Value, " ", "_") 'assuming client name is in column A

    Dim numRanges As Long
    Dim rangeList() As String
    Dim i As Long
    Dim RangeName As String
    Dim currentRangeIndex As Long
    currentRangeIndex = 0
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row ' Find the last row with data in Column A
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")

    For i = 1 To lastRow
        If Cells(i, 1).Interior.ColorIndex = 55 Then 'assuming colorindex 55 represents the start of a new range
            'create named range
            Dim currentRangeEnd As Long
            currentRangeEnd = i - 1
            If currentRangeEnd - currentRangeStart > 0 Then 'check if range has at least 2 rows
                RangeName = currentClientName
                ' Replace spaces and invalid characters with an underscore
                RangeName = Replace(RangeName, " ", "_")
                RangeName = Replace(RangeName, "&", "_")
                RangeName = Replace(RangeName, "-", "_")
                RangeName = Replace(RangeName, "/", "_")
                RangeName = Replace(RangeName, "?", "_")
                RangeName = Replace(RangeName, "[", "_")
                RangeName = Replace(RangeName, "]", "_")
                RangeName = Replace(RangeName, "'", "_")
                RangeName = Replace(RangeName, "(", "_")
                RangeName = Replace(RangeName, ")", "_")
                Dim RngRange As Range
                Set RngRange = Range(Cells(currentRangeStart, 1), Cells(currentRangeEnd, 3)) 'assuming data is in columns A to C
                RngRange.Select
                If Not RangeExists(RangeName) Then
                    ThisWorkbook.Names.Add Name:=RangeName, RefersTo:=RngRange
                    'If you receive an error in this line, it might be that there is a charcter in a name that is not listed in the Replace arguments above i.e. go to the line where it stops and look at the value in the cell, search the character and insert a replace case for that
                End If
                numRanges = numRanges + 1
                ReDim Preserve rangeList(currentRangeIndex)
                rangeList(currentRangeIndex) = RangeName
                currentRangeIndex = currentRangeIndex + 1
                Dim k As Long
                For k = 1 To currentRangeEnd
                    If Cells(k, 1).Interior.ColorIndex = 37 And Not Cells(k, 1).Value = "Liquidités" Then 'assuming colorindex 37 represents the start of a subrange for the current client
                        Debug.Print "ColorIndex: " & Cells(k, 1).Interior.ColorIndex
                        Dim subRangeStart As Long
                        Dim SubRangeName As String
                        Dim subrangeList() As String
                        Dim subRangeIndex As Long
                        Dim numsubRanges As Long
                        subRangeIndex = 0
                        subRangeStart = k
                        Dim subRangeEnd As Long
                        subRangeEnd = GetSubRangeEnd(subRangeStart, currentRangeEnd)
                ' update sub range start to exclude client name row
                        subRangeStart = subRangeStart
                        If subRangeEnd - subRangeStart > 0 Then ' check if sub range has at least 1 row
                            ' create named range
                            SubRangeName = currentClientName
                            SubRangeName = Replace(SubRangeName, " ", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, "&", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, "-", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, "/", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, "?", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, "[", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, "]", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, "'", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, "(", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, ")", "_") & subRangeIndex
                            Dim SubRngRange As Range
                            Set SubRngRange = Range(Cells(subRangeStart, 1), Cells(subRangeEnd, 3)) ' assuming data is in columns A to C
                            SubRngRange.Select
                            If Not SubRangeExists(SubRangeName) Then
                                ThisWorkbook.Names.Add Name:=SubRangeName, RefersTo:=SubRngRange
                            End If
                            numsubRanges = numsubRanges + 1
                            ReDim Preserve subrangeList(subRangeIndex)
                            subrangeList(subRangeIndex) = SubRangeName
                            subRangeIndex = subRangeIndex + 1
                        End If
                    End If
                Next k
            End If
            'update current range start and client name
            currentRangeStart = i
            currentClientName = Cells(currentRangeStart, 1).Value
        End If
        Dim i As Long
        For y = 1 To numRanges
            ' Your code here
            
            ' Add this line after every 50 ranges
            If y Mod 50 = 0 Then Debug.Print "Processed " & y & " ranges"
            
    Next i
    
    ' create last named range
    Dim lastRangeEnd As Long
    lastRangeEnd = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    If lastRangeEnd - currentRangeStart > 0 Then ' check if range has at least 2 rows
        Dim lastRangeName As String
        lastRangeName = currentClientName
        Dim lastRngRange As Range
        Set lastRngRange = ws.Range(ws.Cells(currentRangeStart, 1), ws.Cells(lastRangeEnd, 3)) ' assuming data is in columns A to C
        If Not RangeExists(lastRangeName) Then
            ThisWorkbook.Names.Add Name:=lastRangeName, RefersTo:=lastRngRange
            numRanges = numRanges + 1
            ReDim Preserve rangeList(0 To numRanges - 1)
            rangeList(numRanges - 1) = lastRangeName
        End If
    End If

    ' output number of named ranges created
    MsgBox "Number of named ranges created: " & numRanges
    MsgBox "Number of named subranges created: " & subnumRanges

End Sub
    
'Find duplicated ranges and jump them
Function RangeExists(RangeName As String) As Boolean
    Dim lo As ListObject
    For Each lo In ActiveSheet.ListObjects
        If lo.Name = RangeName Then
            RangeExists = True
            Exit Function
        End If
    Next lo
    RangeExists = False
End Function

Public Function GetSubRangeEnd(ByVal subRangeStart As Long, ByVal lastRow As Long) As Long
    Dim currentRow As Long
    Dim currentCol As Integer
    Dim lastCol As Integer
    
    currentRow = subRangeStart
    currentCol = 1 ' assuming data starts in column A
    lastCol = 3 ' assuming data ends in column C
    
    'Find the last row of the subrange
    Do While Not IsEmpty(Cells(currentRow, currentCol))
        If currentRow > lastRow Then Exit Do
        currentRow = currentRow + 1
    Loop
    
    'Find the last column of the subrange
    Do While Not IsEmpty(Cells(subRangeStart, lastCol + 1))
        lastCol = lastCol + 1
    Loop
    
    GetSubRangeEnd = Cells(currentRow - 1, lastCol).Row
End Function


'Find duplicated ranges and jump them
Function SubRangeExists(SubRangeName As String) As Boolean
    Dim lo As ListObject
    For Each lo In ActiveSheet.ListObjects
        If lo.Name = SubRangeName Then
            SubRangeExists = True
            Exit Function
        End If
    Next lo
    SubRangeExists = False
End Function

Answer 1

我不完全明白你的意思。

无论如何，下面的代码应该在包含活动数据的工作表中逐步运行。

Sub test()
Dim rg As Range, rgMain As Range, rgSub As Range
Dim v

With Sheet1
Set rg = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
End With

Application.FindFormat.Interior.ColorIndex = 55
With rg
    v = .Value
    .ClearContents
    .Replace "", True, xlWhole, , False, , True, False
    Set rgMain = .SpecialCells(xlConstants, xlLogical)
    .Value = v
End With

Application.FindFormat.Interior.ColorIndex = 37
With rgMain.Offset(0, 1)
    v = .Value
    .ClearContents
    .Replace "", True, xlWhole, , False, , True, False
    Set rgSub = .SpecialCells(xlConstants, xlLogical)
    .Value = v
End With

For Each cell In rgSub
cell.Select
Next

End Sub

代码仅基于此引用：

我创建了一个代码来定义 mainranges 基于 colorindex 55 这很好用。在这些范围内，我必须创建 基于颜色索引 37

的子范围

示例数据：

因此，“MainRanges”包含 A 列中颜色为紫色的单元格。
SubRange 的预期结果包含单元格 B4、B8、B10 和 B17。

代码为A列中的数据创建rg。
然后它从 rg 创建 rgMain，其中单元格有紫色填充。
然后它从具有蓝色填充的 rgMain.offset(0,1) 创建 rgSub。

当step运行循环部分的代码时，
它将选择单元格 B4、B8、B10，然后最后选择 B17。

也许可以帮助您解决问题。