Excel Comparar valores e copiar

O_Aprendiz · 16 de fevereiro de 2022

Olá!

Alguém que seja expert em VBA e que tenha alguns minutinhos consegue analisar o código e dar um help?!

Eu preciso que esta macro compare os valores de uma célula em uma planilha(1) com uma coluna em outra planilha(2) e caso os valores constem, que ele copie os valores para a mesma linha da planilha(1) e se não nessa comparação o valor não estiver na planilha(2), que ele copie determinadas células no final da tabela.

Fiz vários testes aqui, mas chega em determinado ponto que a macro pula "misteriosamente" para outra macro do mesmo arquivo. rs

Se alguém já tiver algum modelo assim e puder compartilhar também, será muito bem vindo!

Muito obrigado!

Sub Procura()
Dim valor1 As Variant
Dim valor2 As Variant
Dim arquivo_origem As Variant
Dim arquivo_destino As Variant
Dim posicao1 As Range
Dim posicao2 As Range
Dim planilhadestino As Workbook
Dim planilhaorigem As Workbook
Dim guiadestino As Worksheet
Dim guiaorigem As Worksheet
Dim planilhaativa As Worksheet
Dim ultimalinhaplan1 As Long
Dim ultimalinhaplan2 As Long
Dim variavel2 As Long
Dim variavel3 As Long
Dim valorprocurado As Range


Set planilhaorigem = ThisWorkbook: Set guiaorigem = planilhaorigem.ActiveSheet
'guiadestino = Worksheets("Novo")
'guiaorigem = Worksheets("Acompanhamento")

Set arquivo_origem = ThisWorkbook.ActiveSheet
arquivo_destino = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Escolha o arquivo:")
If arquivo_destino = False Then MsgBox "Erro!": Exit Sub
  Set planilhadestino = Workbooks.Open(arquivo_destino)
  
  Application.ScreenUpdating = False
    planilhadestino.Activate
Set guiadestino = Sheets("Planilha1")
Set planilhaativa = guiadestino
   planilhaativa.Activate
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
  ActiveSheet.ShowAllData
  End If
  ultimalinhaplan1 = guiadestino.Cells(Rows.Count, 1).End(xlUp).Row
If ultimalinhaplan1 < 2 Then MsgBox "Erro!": Exit Sub

Set valorprocurado = Worksheets("Planilha1").Range("D2:D1000")

planilhaorigem.Activate

  With guiaorigem
   'On Error Resume Next
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
  ActiveSheet.ShowAllData
  End If
   On Error GoTo 0
   If .[C2] = "" Then ultimalinhaplan2 = 1 Else: ultimalinhaplan2 = .Cells(Rows.Count, 1).End(xlUp).Row
   guiaorigem.Activate
   
   Range("G8").Select 
   
Do Until ActiveCell = "" 

    ActiveCell.Offset(1, 0).Select 

    If ActiveCell = "valorprocurado" Then   
    
   .Range("E9:G" & ultimalinhaplan1 & ",J9:J" & ultimalinhaplan1 & ",T9:T" & ultimalinhaplan1).Copy

planilhadestino.Activate
guiadestino.Activate
    
    .Range("D9:F" & ultimalinhaplan1 & ",H9:H" & ultimalinhaplan1 & ",R9:R" & ultimalinhaplan1).ClearContents
    .Range("D9:F" & ultimalinhaplan1 & ",H9:H" & ultimalinhaplan1 & ",R9:R" & ultimalinhaplan1).Paste
    
    ElseIf ActiveCell = "" Then 
    End If
    
    Loop
    .Range("A1").Select ' retorna para o inicio da coluna
    .Range("E9:G" & ultimalinhaplan1 & ",J9:J" & ultimalinhaplan1 & ",T9:T" & ultimalinhaplan1).Copy
    .Cells(ultimalinhaplan2 + 1, 1).PasteSpecial xlValues
    variavel3 = .Cells(Rows.Count, 1).End(3).Row

  End With

Exit Sub
errH: MsgBox "Erro!"
End Sub