Robson Cardoso

Consegui galera, segue o código a quem precise de algo parecido;
Sub Find_Matches() Dim CompareRange As Variant, x As Variant, y As Variant, Z As Variant Dim iRet As Integer Dim strPrompt As String Dim strTitle As String ' Promt strPrompt = "Deseja copiar os códigos existentes?" ' Dialog's Title strTitle = "Copiar códigos" 'Display MessageBox iRet = MsgBox(strPrompt, vbYesNo, strTitle) ' Check pressed button If iRet = vbNo Then Else Application.ScreenUpdating = False Set CompareRange = Range("C7", ActiveSheet.Range("C65536").End(xlUp)) CompareRange.Select For Each x In Selection If x.Offset(0, -2).Value <> "" Then Z = x.Offset(0, -2).Value For Each y In CompareRange If x = y Then y.Offset(0, -2).Select If ActiveCell = "" Then ActiveCell.Value = Z End If Next y Else End If Next x End If End Sub Caso alguém tenha alguma sugestão podem falar