Olá Rapaziada!

Entao, to me batendo com um problema aqui:

Eu tenho duas Sheets (Tabela 1 - Fonte / Tabela 2 - Destino) quase identicas, a estrutura das colunas é a mesma mas a diferenca é que uma delas possui uma coluna a mais (Coluna A). O objetivo do codigo que eu tentei escrever e pegar todas as informacoes da Tabela 1 e tranferir para a tabela dois de acordo com os criterios que coloquei.

De forma mais facil seria : Se Celula bla bla nao for vazia copiar o Range tal tal, sendo este "Se" repetido cinco vezes. O código esta em anexo, e tambem esta funcionando só que na minha opiniao poderia ficar melhor.

Sub AIDatabase()

Dim Final As Worksheet
Dim TopAIs As Worksheet

Application.ScreenUpdating = False

Set Final = Worksheets("Final")
Set TopAIs = Worksheets("AI Database")

Final.Activate

For i = 3 To 7000

On Error Resume Next

    If Not Final.Cells(i, 22).Value = "" Then
    
            TopAIs.Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Final.Cells(i, 22).Value
            Final.Range(Cells(i, 1), Cells(i, 105)).Copy
            TopAIs.Range("A" & Rows.Count).End(xlUp).Offset(0, 1).PasteSpecial
        
            If Not Final.Cells(i, 28).Value = "" Then

                TopAIs.Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Final.Cells(i, 28).Value
                Final.Range(Cells(i, 1), Cells(i, 105)).Copy
                TopAIs.Range("A" & Rows.Count).End(xlUp).Offset(0, 1).PasteSpecial

                    If Not Final.Cells(i, 34).Value = "" Then
                        
                        TopAIs.Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Final.Cells(i, 34).Value
                        Final.Range(Cells(i, 1), Cells(i, 105)).Copy
                        TopAIs.Range("A" & Rows.Count).End(xlUp).Offset(0, 1).PasteSpecial
                    
                            If Not Final.Cells(i, 40).Value = "" Then

                                TopAIs.Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Final.Cells(i, 40).Value
                                Final.Range(Cells(i, 1), Cells(i, 105)).Copy
                                TopAIs.Range("A" & Rows.Count).End(xlUp).Offset(0, 1).PasteSpecial

                                    If Not Final.Cells(i, 46).Value = "" Then
                                    
                                            TopAIs.Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Final.Cells(i, 46).Value
                                            Final.Range(Cells(i, 1), Cells(i, 105)).Copy
                                            TopAIs.Range("A" & Rows.Count).End(xlUp).Offset(0, 1).PasteSpecial
                                            
                                    End If
                            
                            End If
                            
                    End If
                 
              End If
        
    End If

Next

End Sub

Ja que estou falando de um banco de dados de 7000 linhas o processo de Copy&Paste demora demais. Eu preciso de cerca de 3:30 min para rodar a macro, e tenho certeza que pode ficar mais rapido se eu substituir a forma de importacao (Copy&Paste).

O que eu estava pensando era em algo como:

Se Celula bla bla nao for vazia then
Tabela1.Range(Celulas (tal,tal), Celulas (tal,tal)).value = Tabela2.(Celulas (tal2,tal2), Celulas (tal2,tal2)).value

Assim eu pouparia o processo de copiar e colar 7000 vezes para 5 "Ses".

Sacaram? Alguem podia me dar uma dica de como reduzir esse tempo?

Valeu pela ajuda e um grande abraco!