时间戳

首页 > 解决方案 > 从执行时定义的一系列单元格中复制与内部颜色匹配的单元格（ExcelVBA）

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

问题描述

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

我尝试的解决方案涉及使用“Application.CountIf（范围，条件）”来计算颜色为 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）着色的单元格的行范围。我添加了条件来检查是否存在所述颜色的单元格，因为如果工作表没有单元格，则会出现范围 Autofilter 属性的错误。但是，正如我所说，它似乎没有正确计算单元格，我不确定如何解决它。

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

标签： excelvbarangecountifautofilter

解决方案

我在 Microsoft 支持中找到了基于这篇文章的解决方法。

必须创建一个函数来接收要分析的单元格范围以及要计算的单元格内部颜色的标准。此函数的行为方式与 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

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

推荐阅读