從執行時定義的一系列單元格中復制與內部顏色匹配的單元格 (ExcelVBA)

Question

我在使用 Excel VBA 時遇到的問題是，在按顏色 (RGB(1, 255, 1)) 在工作表 (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) 着色的單元格的行范圍。 我添加了條件來檢查是否有所述顏色的單元格，因為如果工作表沒有單元格，則會出現范圍 Autofilter 屬性的錯誤。 但是，正如我所說，它似乎沒有正確計算細胞數，我不確定如何解決它。

請幫助我並提前致謝（並抱歉我的英語不好）

Answer 1

我在 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

我希望它可以幫助其他可能遇到這種情況的人。