Question

我在使用Excel VBA时遇到的问题是尝试在工作表（workbookB）的工作表中应用某种颜色（RGB（1，255，1））进行过滤之前，先验证工作簿（workbookB）的工作表中是否存在某种颜色的单元格（ SheetNameFromArray），然后将可见的单元格复制到另一个具有相同名称（SheetNameFromArray）的工作簿（workbookA）工作表中。

我尝试的解决方案涉及使用“ Application.CountIf（range，condition）”对具有RGB（1，255，1）颜色的单元格进行计数，然后如果存在具有该颜色的单元格，则继续进行过滤和复制。但是，由于某种原因，似乎无法正确计数单元格，因为即使工作表中具有该颜色的单元格在范围内，它也不会复制任何单元格（请参见以下示例）：

    LastSheetRow = Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(Rows.Count, 1).End(xlUp).Row
    LastSheetColumn = Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(1, Columns.Count).End(xlToLeft).Column

    WorkbookALastSheetRow = Workbooks(WorkbookA).Sheets(SheetNameFromArray).Cells(Rows.Count, 1).End(xlUp).Row

    Dim rngWorkbookBToCopy As Range, rngWorkbookAToPaste As Range
    With Workbooks(WorkbookB).Sheets(SheetNameFromArray)
        Set rngWorkbookBToCopy = .Range(.Cells(2, 1), .Cells(LastSheetRow, LastSheetColumn - 1))
    End With
    With Workbooks(WorkbookA).Sheets(RevisionSheetNameFromArray)
        Set rngWorkbookAToPaste = .Cells(WorkbookALastSheetRow, 1)
    End With

    If Application.CountIf(rngWorkbookBToCopy, RGB(1, 255, 1)) = 0 Then
    Else
        With Workbooks(WorkbookB).Worksheets(RevisionSheetNameFromArray)
            .Range(.Cells(1, 1), .Cells(LastSheetRow, LastSheetColumn)).AutoFilter Field:=1, Criteria1:=RGB(1, 255, 1), Operator:=xlFilterCellColor
        End With            
        rngWorkbookBToCopy.SpecialCells(xlCellTypeVisible).Copy rngWorkbookAToPaste           
    End If

我想做的是仅复制至少具有以RGB（96，255，210）着色的单元格的行范围。我添加了条件来检查是否存在上述颜色的单元格，因为如果工作表中没有单元格，则会出现范围自动过滤器属性错误。但是，正如我说的那样，似乎无法正确计数细胞，而且我不确定如何解决。

请帮助我，并提前感谢（对不起，我的英语不好）

Answer 1

我发现了一种基于this post at Microsoft support.

的解决方法

必须创建一个函数来接收要分析的单元格范围和要计数的单元格内部颜色的标准。此函数的行为与CountIf预期用于问题发布的方式类似（计算具有某种内部颜色的单元格）。

Function CountCcolor(range_data As Range, criteria As Long) As Long
    Dim datax As Range
    Dim xcolor As Long
    xcolor = criteria
    For Each datax In range_data
        If datax.Interior.Color = xcolor Then
            CountCcolor = CountCcolor + 1
        End If
    Next datax
End Function

应用此更改，现在的代码如下：

LastSheetRow = Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(Rows.Count, 1).End(xlUp).Row
LastSheetColumn = Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(1, Columns.Count).End(xlToLeft).Column

WorkbookALastSheetRow = Workbooks(WorkbookA).Sheets(SheetNameFromArray).Cells(Rows.Count, 1).End(xlUp).Row

Dim rngWorkbookBToCopy As Range, rngWorkbookAToPaste As Range
With Workbooks(WorkbookB).Sheets(SheetNameFromArray)
    Set rngWorkbookBToCopy = .Range(.Cells(2, 1), .Cells(LastSheetRow, LastSheetColumn - 1))
End With
With Workbooks(WorkbookA).Sheets(RevisionSheetNameFromArray)
    Set rngWorkbookAToPaste = .Cells(WorkbookALastSheetRow, 1)
End With

If CountCcolor(rngWorkbookBToCopy, RGB(1, 255, 1)) = 0 Then
Else
    With Workbooks(WorkbookB).Worksheets(RevisionSheetNameFromArray)
        .Range(.Cells(1, 1), .Cells(LastSheetRow, LastSheetColumn)).AutoFilter Field:=1, Criteria1:=RGB(1, 255, 1), Operator:=xlFilterCellColor
    End With            
    rngWorkbookBToCopy.SpecialCells(xlCellTypeVisible).Copy rngWorkbookAToPaste           
End If

我希望它可以帮助可能遇到这种情况的其他人。

从执行时定义的一系列单元格中复制与内部颜色匹配的单元格（ExcelVBA）

1 个答案: