Loop through Find then special paste background color with VBA

Hello,

I am trying to run a loop that automatically finds a cell value from Worksheet 1 on Worksheet 2 and then special pastes the cell's background color to the corresponding cell on Worksheet 1. For example, it sees cell "Apple" on Worksheet 1, finds a cell with "Apple" which happens to have a red background on Worksheet 2, returns to Worksheet 1 to special paste a red background to cell "Apple".

The formula I use does not work. Please let me know what I'm doing wrong

Formula:

Sub Macro3()

'

' Macro3 Macro

'



'

Dim x As Integer

Z = 1



Do



Sheets("Sheet1").Activate

Cells(6, "x").Select

    Application.CutCopyMode = False

    Selection.Copy

    Sheets("Sheet2").Select

    Cells.find(What:="x", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Activate

    ActiveCell.Select

    Application.CutCopyMode = False

    Selection.Copy

    Sheets("Sheet1").Select

    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _

        SkipBlanks:=False, Transpose:=False



ActiveCell.Offset(1, 0).Select

Z = Z + 1

If IsEmpty(ActiveCell) Then

Exit Do

End If

Loop Until Z = 330

End Sub

You need an If statement to determine if the cell found in worksheet 2 has the red background AND the corresponding text.

I will definitely try to work one in. However, I am not looking for a specific background. There's a matching list of names on each worksheet, I want to copy whatever the background color is from Worksheet 2 to the cell with the same name in worksheet 1. Does that make sense?

Now I'm using the following formula, but receiving an error message. Anyone have any idea how to fix this?

Formula:

Sub finaagain()

Dim server As String



Sheets("Sheet1").Activate

Range("F1").Select





Do Until IsEmpty(ActiveCell)

ActiveCell.Offset(1, 0).Select

server = ActiveCell.Value

Sheets("Sheet2").Select

Cells.find(What:=server, after:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate



    Application.CutCopyMode = False

    Selection.Copy

    Sheets("Sheet1").Select

    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _

        SkipBlanks:=False, Transpose:=False



Loop

End Sub