CODEWITHSUNDEEP
excelvbacolorsmatch
user3812753
user3812753

Reputation: 79

Excel VBA: Find the values and paste only the colors (problem with no color)

long time no see. I am dealing with a little task, that somehow I cannot wrap my head around. I have a huge excel sheet (around 4000 rows) which is being split and sent out to people - they mark yellow or red cells from K column to T column in the specific row and send it back every week, until the range K to T in those 4000 rows that has "X" value (meaning sent out) are marked either yellow or red (received back or not received). The excel sheet has a unique value in column J (so I am using MATCH). So by using this column J, I am going through each line in Data (Master sheet) and checking if this is found in Input sheet (something that has been returned from users), if it is found I go and copy the color of their marking to the original Data sheet. This works great as a charm for those yellow and red colors, the sub itself runs fast - just wondering if there are no errors (last time I did some macros were 3 years ago). The problem - if the cell is empty, it is being pasted as WHITE back to the Data sheet and the original grid of the excel is gone (hard to read). Can anyone point me into the right direction? Thank you!

Sub test4()
Application.ScreenUpdating = False
Set dat = Sheets("Data")
n = dat.Range("J" & Rows.Count).End(xlUp).Row

Dim test As Long
For i = 2 To n
    inputrow = 0
    On Error Resume Next
    inputrow = Application.WorksheetFunction.Match(Worksheets("Data").Range("J" & i).Value, Sheets("Input").Range("J:J"), 0)
    On Error GoTo 0
    If inputrow > 0 Then
o = dat.Range("A" & Rows.Count).End(xlUp).Row + 1
        dat.Range("K" & i).Interior.Color = Sheets("Input").Range("K" & inputrow).DisplayFormat.Interior.Color
        dat.Range("L" & i).Interior.Color = Sheets("Input").Range("L" & inputrow).DisplayFormat.Interior.Color
        dat.Range("M" & i).Interior.Color = Sheets("Input").Range("M" & inputrow).DisplayFormat.Interior.Color
        dat.Range("N" & i).Interior.Color = Sheets("Input").Range("N" & inputrow).DisplayFormat.Interior.Color
        dat.Range("O" & i).Interior.Color = Sheets("Input").Range("O" & inputrow).DisplayFormat.Interior.Color
        dat.Range("P" & i).Interior.Color = Sheets("Input").Range("P" & inputrow).DisplayFormat.Interior.Color
        dat.Range("Q" & i).Interior.Color = Sheets("Input").Range("Q" & inputrow).DisplayFormat.Interior.Color
        dat.Range("R" & i).Interior.Color = Sheets("Input").Range("R" & inputrow).DisplayFormat.Interior.Color
        dat.Range("S" & i).Interior.Color = Sheets("Input").Range("S" & inputrow).DisplayFormat.Interior.Color
        dat.Range("T" & i).Interior.Color = Sheets("Input").Range("T" & inputrow).DisplayFormat.Interior.Color
    End If
Next i

End Sub

Upvotes: 0

Views: 394

Answers (1)

Tim Williams
Tim Williams

Reputation: 166540

DisplayFormat.Interior.ColorIndex = xlNone will be True if the cell has not been colored. Unless you're working with Conditional Formatting you don't need the DisplayFormat

Sub test4()
    Dim test As Long, inputrow, dat As Worksheet, wsInput As Worksheet
    Dim n As Long, i As Long, c As Long, o
    
    Application.ScreenUpdating = False
    
    Set wsInput = Sheets("Input")
    Set dat = Sheets("Data")
    
    n = dat.Range("J" & Rows.Count).End(xlUp).Row
    
    For i = 2 To n
        
        inputrow = Application.Match(dat.Range("J" & i).Value, wsInput.Range("J:J"), 0)
        
        If Not IsError(inputrow) Then 'check for match
            o = dat.Range("A" & Rows.Count).End(xlUp).Row + 1
            'loop over columns
            For c = 11 To 20
                With wsInput.Rows(inputrow).Cells(c)
                    'copy color if cell is not default color
                    If .Interior.ColorIndex <> xlNone Then
                        dat.Cells(i, c).Interior.Color = .Interior.Color
                    End If
                End With
            Next c
        End If 'got match
    Next i
End Sub

Upvotes: 2

Related Questions