简体   繁体   中英

Copy Range From One Sheet Paste Part of Range In another Sheet Based On Cell colorindex

I am trying to copy a range of cells on one worksheet and paste the color on another worksheet based on the colorindex.

I want to copy cells on sheet1

IMG1

and only paste cells with colorindex = 49 on sheet2

IMG2

This is what I've tried doing: Is there a better or faster way of doing this than writing 90 If statements?

Private Sub CommandButton3_Click()

If Range("A1").Interior.ColorIndex = 49 Then
Worksheets("Sheet2").Range("A1").Interior.ColorIndex = 49
Else: Range("A1").Interior.ColorIndex = -4142
End If

If Range("A2").Interior.ColorIndex = 49 Then
Worksheets("Sheet2").Range("A2").Interior.ColorIndex = 49
Else: Range("A2").Interior.ColorIndex = -4142
End If

If Range("A3").Interior.ColorIndex = 49 Then
Worksheets("Sheet2").Range("A3").Interior.ColorIndex = 49
Else: Range("A3").Interior.ColorIndex = -4142
End If

If Range("A4").Interior.ColorIndex = 49 Then
Worksheets("Sheet2").Range("A4").Interior.ColorIndex = 49
Else: Range("A4").Interior.ColorIndex = -4142
End If

If Range("A5").Interior.ColorIndex = 49 Then
Worksheets("Sheet2").Range("A5").Interior.ColorIndex = 49
Else: Range("A5").Interior.ColorIndex = -4142
End If

End Sub

Try this function

Function GetFillColor(Rng As Range) As Long
      GetFillColor = Rng.Interior.ColorIndex
End Function

Then you can use it in an if statement. If getfillcolor(cell) = 49 then do something

You can use this snippet to copy the interior color over to the second sheet. If you want to specify another 'second' sheet that already exists you can put the sheet name like this instead Sheets("Sheet Name").Interior ... .

If sheets.count < 2 Then sheets.Add after:=sheets(1)

Dim theCell As Range
For Each theCell In sheets(1).Range("A1:E16")
    With theCell
        If .Interior.ColorIndex = 49 Then
            sheets(2).Cells(.row, .Column).Interior.ColorIndex = 49
        Else
            sheets(2).Cells(.row, .Column).Interior.ColorIndex = -4142
        End If
    End With
Next theCell

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM