VBA - 创建“颜色检查范围”以反转循环

Posted 2023-02-19

【中文标题】VBA - 创建“颜色检查范围”以反转循环

【英文标题】：VBA - Creating a "Color Check Range" to Reverse Loop

【发布时间】：2021-03-17 17:22:42

【问题描述】：

目前有一个反向循环寻找cells.font.strikethrough = true

一旦找到，我将使用该单元格作为我的.find 的起点，以查找上面具有Interior. Color = RGB(0,0,0) 的第一个单元格并首先将该值复制/粘贴到目标，然后偏移具有删除一列并删除整行数据。

为了我最近糟糕的交流： 父单元格 = 黑色背景 子单元格 = 父单元格下方没有黑色背景的每个单元格

具有黑色背景的单元格永远不能与某些子单元格同时删除/删除，因为并非所有子单元格都会同时移动到另一个工作表。

数据填充到此工作簿中，如下所示：

 Parent
 child
 child
 child
 Parent
 child
 child
 child
 child
 child

等等。每个父级的子单元格的数量是未知的。

以上面的示例为例，当所有子单元格都已为父母双方移动/删除时，这会导致 2 个父母位于彼此上方/下方，除了手动删除行之外，无法删除它们。像这样：

Parent
Parent

导致我想要进行“父单元格颜色检查”的问题

总结：

当反向循环搜索删除线时，宏最终会穿过一个黑色背景的单元格

一旦发生这种情况，请检查该单元格上方是否有另一个黑色背景，然后继续检查上方，直到它碰到没有黑色背景的单元格，然后我想删除所有连续的黑色背景行。

我能想到这种情况的唯一直接问题：

Parent
Parent
Parent
Child (no strikethrough)

我认为上述逻辑最终会删除尚未删除的孩子的父母，这是我不想要的，我不知道如何防止。

子单元格将始终位于父单元下方，因此可能在第一个父单元的上方和下方进行另一位代码检查以查看子单元是否存在，如果没有子单元格，则使用该位置作为父单元检查的起始范围？我不知道，我的大脑很痛，这两天就要到期了！

抱歉啰嗦了这么久！这就是我现在正在使用的东西。

Private Sub CommandButton1_Click()

Dim ipWS As Worksheet, compWS As Worksheet
Dim compDest As Range, rrCell As Range
Dim i As Integer
Dim alastRow As Long

Set ipWS = ThisWorkbook.Worksheets("In Processing")
Set compWS = ThisWorkbook.Worksheets("Completed")


alastRow = ipWS.Cells(Rows.Count, 1).End(xlUp).Row


Dim rackRng As Range
Dim cellRng As Range

Set compDest = compWS.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

Application.FindFormat.Interior.Color = RGB(0, 0, 0)


For i = alastRow To 1 Step -1

            
            If Range(Cells(i, 1), Cells(i, 1)).Font.Strikethrough = True Then
           
                Set rackRng = ipWS.Range(Cells(i, 1), Cells(i, 1).End(xlUp)).Find("*", , , , , xlPrevious, , , SearchFormat:=True)
                    rackRng.Copy compDest
                        Application.CutCopyMode = False
                
                Range(Cells(i, 1), Cells(i, Columns.Count).End(xlToLeft)).Copy compDest.Offset(0, 1)
                    Application.CutCopyMode = False
                
                        Set compDest = compDest.Offset(1, 0)
                    
                    Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
            End If

Next i
            With compWS.Range("A:P")
                .Font.Strikethrough = False
                .ColumnWidth = 25
                .Font.Size = 14
                .WrapText = True
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlVAlignCenter
            End With

End Sub

更新

此图显示删除线单元格正在“完成”，因此需要转移到“已完成”工作表。

将我当前的代码编程到按钮上，这是“已完成”工作表上的结果。

留下如下图所示的“处理中”表。

因为“12/3/2020 110”和“12/3/2020 96”的所有子单元格都已被删除，我正在寻找一种方法将代码添加到删除 2 个父单元格的按钮（仅当所有子单元格都已移至“已完成”工作表时）

【参考方案1】：

使用格式标准复制和删除

守则

Option Explicit

Sub updateData()
    
    Const ProcName As String = "updateData"
    On Error GoTo clearError

    ' Source
    Const srcName As String = "In Processing"
    Const srcFirst As String = "D10"
    ' Destination
    Const dstName As String = "Completed"
    ' Workbook
    Dim wb As Workbook
    Set wb = ThisWorkbook
  
    ' Define Source First Cell.
    Dim cel As Range
    Set cel = wb.Worksheets(srcName).Range(srcFirst)
    ' Define Source Range assuming data is contiguous with an empty column
    ' to the right, and an empty row at the bottom. Data adjacent
    ' to the left and to the top is allowed.
    Dim rng As Range
    With cel.CurrentRegion
        Set rng = cel.Resize(.Rows.Count + .Row - cel.Row, _
            .Columns.Count + .Column - cel.Column)
    End With
    
    Dim CopyList As Object
    Set CopyList = CreateObject("System.Collections.ArrayList")
    Dim DeleteList As Object
    Set DeleteList = CreateObject("System.Collections.ArrayList")
    
    Dim i As Long          ' Source Counter
    Dim cCount As Long     ' Copy Counter
    Dim dCount As Long     ' Delete Counter
    Dim iCopied As Boolean ' Interior Color Row Copied
    Dim iRow As Long       ' Interior Color Row
    Dim sRow As Long       ' Strike Through Row
    
    ' Write the row numbers of the rows to be copied and/or deleted
    ' to the array lists.
    iRow = -1 ' Necessary for the second 'If' statement's logic to work.
    For Each cel In rng.Columns(1).Cells
        i = i + 1
        If cel.Interior.Color = RGB(0, 0, 0) Then
            If i - sRow - 1 = iRow Then
                dCount = dCount + 1
                DeleteList.Add iRow
            End If
            iRow = i
            sRow = 0
            iCopied = False
        ElseIf cel.Font.Strikethrough Then
            If Not iCopied Then
                cCount = cCount + 1
                CopyList.Add iRow
                iCopied = True
            End If
            cCount = cCount + 1
            dCount = dCount + 1
            CopyList.Add i
            DeleteList.Add i
            sRow = sRow + 1
        End If
    Next cel
    
    If cCount > 0 Then
        Application.ScreenUpdating = False
        Dim CopyRange As Range ' ByRef
        Dim DeleteRange As Range ' ByRef
        Dim RowNumber As Variant ' Has to be 'Variant'.
        ' Write to Destination Worksheet.
        For Each RowNumber In CopyList
            buildRange CopyRange, rng.Rows(RowNumber)
        Next RowNumber
        With wb.Worksheets(dstName)
            CopyRange.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 1)
            With .Range("A:P")
                .Font.Strikethrough = False
                .ColumnWidth = 25
                .Font.Size = 14
                .WrapText = True
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlVAlignCenter
            End With
        End With
        ' Delete rows in Source Worksheet.
        DeleteList.Sort
        For Each RowNumber In DeleteList
            buildRange DeleteRange, rng.Columns(1).Cells(RowNumber)
        Next RowNumber
        DeleteRange.EntireRow.Delete
        Application.ScreenUpdating = True
        MsgBox "Number of copied rows: " & cCount & vbLf _
            & "Number of deleted rows: " & dCount, vbInformation, "Update"
    Else
        MsgBox "No rows deleted.", vbInformation, "Update"
    End If

ProcExit:
    Exit Sub

clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit

End Sub


Sub buildRange( _
        ByRef BuiltRange As Range, _
        AddRange As Range)
    If Not AddRange Is Nothing Then
        If Not BuiltRange Is Nothing Then
            Set BuiltRange = Union(BuiltRange, AddRange)
        Else
            Set BuiltRange = AddRange
        End If
    End If
End Sub

【讨论】：

如果您看到了之前的评论，我们很抱歉造成混淆。用户错误。

但是，出于测试目的，我将 srcFirst 单元格更改为“A1:A10”。我从 cmd 按钮调用了 updataData 子，但什么也没发生。抱歉，我大约 2 个月前开始使用 vba，而我了解代码在做什么，有些部分我根本不熟悉。如果这有助于填补我有限的知识空白，我会用图片更新我的帖子。

srcFirst 必须设置为 A1 或数据开始的位置：仅一个单元格。上传一两张图片总是一个好主意，例如之前和之后。

再次道歉，我一开始就应该这样做。