使用VBA根據單元格格式（單元格背景顏色）有條件地選擇Excel單元格值

Question

我想打印背景黃色與單元格相同且背景白色為 [0,0] 的值，我想得到這種情況

[1,9],[0,0],[1,7],[1,6],[0,0],[1,4],[0,0],[1,2],[0] ,0]

我寫了一些代碼

        Dim isect As Range
        Set isect = Intersect(Target, Me.Range("$B$80:$J$80"))
        If Not isect Is Nothing Then
                       
               Dim s As String
               If Target.Interior.Color = vbYellow Then
                s = Target.Value
                Else
                s = "[0,0]"
                End If
               Range("D96").Value = s

但它只有一個值，我應該怎么做才能繼續。 任何幫助將不勝感激。

Answer 1

Dim isect As Range
Dim aCell As Range
Dim Output As String

Set isect = Intersect(target, Me.Range("$B$80:$J$80"))

If Not isect Is Nothing Then
    For Each aCell In isect 
        If aCell.Interior.Color = vbYellow Then
            Output = Output & "," & aCell.Value
        Else
            Output = Output & "," & "[0,0]"
        End If
    Next aCell
    Range("D96") = Mid(Output, 2)
End If    

這是你想要的嗎？

Answer 2

取決於單元格屬性（填充顏色）

標准模塊代碼（例如Module1 ）

Option Explicit

Function getString(SourceRange As Range, _
                   Optional ByVal FillColor As Long = 0, _
                   Optional ByVal CriteriaNotMetValue As Variant = Empty, _
                   Optional ByVal Delimiter As String = ", ") _
         As String
    
    If SourceRange Is Nothing Then Exit Function
    
    ' Write values of range to array.
    Dim Data As Variant
    If SourceRange.Rows.Count > 1 Or SourceRange.Columns.Count > 1 Then
        Data = SourceRange.Value
    Else
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = SourceRange.Value
    End If
    
    ' Modify values in array.
    Dim i As Long, j As Long, Result As String
    For i = 1 To UBound(Data)
        For j = 1 To UBound(Data, 2)
            If SourceRange.Cells(i, j).Interior.Color <> FillColor Then
                Data(i, j) = CriteriaNotMetValue
            End If
            Result = Result & Delimiter & Data(i, j)
        Next j
    Next i
            
    ' Remove redundant Delimiter.
    getString = Right(Result, Len(Result) - Len(Delimiter))
    
End Function

工作表代碼（例如Sheet1 ）

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Const rngAddress As String = "B80:J80"
    Const cellAddress As String = "D96"
    Const CriteriaNotMetValue As Variant = "[0,0]"
    Const FillColor As Long = vbYellow
    Const Delimiter As String = ","
    
    If Intersect(Me.Range(rngAddress), Target) Is Nothing Then Exit Sub

    On Error GoTo clearError
    Application.EnableEvents = False
    Dim Result As String
    Result = getString(Me.Range(rngAddress), FillColor, CriteriaNotMetValue, Delimiter)
    Me.Range(cellAddress).Value = Result
    
CleanExit:
    Application.EnableEvents = True
    Exit Sub
    
clearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    On Error GoTo 0
    GoTo CleanExit
    
End Sub