使用VBA根据单元格格式单元格背景色有条件地选择Excel单元格值

如何解决使用VBA根据单元格格式单元格背景色有条件地选择Excel单元格值

我要在背景黄色与单元格相同且背景白色为[0,0]的情况下打印值 对于这种情况，我想得到

[1,9]，[0,0]，[1,7]，[1,6]，[0,4]，[0,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

但是它仅获得一个值，这是我继续做的。 任何帮助将不胜感激。

解决方法

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    

这是您想要的吗？

,

取决于单元格属性（填充颜色）

标准模块代码（例如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