Optimization in VBA code?

Question

I have two spreadsheets, both have the same header, with 77 columns. For testing I put 4 rows with data filled in one of the tables. In the table with the data filled, I have the button with the macro, to copy this data to the worksheet that has only the header, but for this macro to finish the copy to the other worksheet it takes approximately 30 minutes. As the purpose is to optimize a manual process, in which there will be much more than 4 rows of filled data, the macro will become unviable in this way. Is there a way to optimize the code and reduce that time ? The code is as follows:

Sub Percorre()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False

Dim contador, col As Integer
Dim valor, PastaAtual, NomeDoArquivo, NomeCompletoDoArquivo As String
Dim Busca As Range
Dim RangeFrom As Range
Dim RangeTo As Range
Dim Busca_col As Integer
Dim WorkBookNovo As Workbook

contador = 0
col = 1


ThisWorkbook.Worksheets("Aspiradores").Activate
PastaAtual = Application.ActiveWorkbook.Path
NomeDoArquivo = "teste.xlsx"
NomeCompletoDoArquivo = PastaAtual + "\" + NomeDoArquivo
Set WorkBookNovo = Workbooks.Open(NomeCompletoDoArquivo)
ThisWorkbook.Worksheets("Aspiradores").Activate

Do While Cells(2, col).Value <> ""

    Cells(2, col).Select
    valor = Cells(2, col).Value

    Columns(col).Select
    numRows = Selection.Rows.Count
    Selection.Resize(numRows - 1).Select
    Selection.Offset(1, 0).Select
    Set RangeFrom = Selection

    WorkBookNovo.Activate
    Set Busca = WorkBookNovo.Application.Cells.Find(What:=valor, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    Busca.Activate
    Busca_col = Busca.Column
    WorkBookNovo.ActiveSheet.Columns(Busca_col).Select
    numRows = Selection.Rows.Count
    Selection.Resize(numRows - 1).Select
    Selection.Offset(1, 0).Select
    Selection.Value = RangeFrom.Value
    ThisWorkbook.Worksheets("Aspiradores").Activate
    contador = contador + 1
    col = col + 1
Loop

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub

Answer 1

For any code optimization work, one of the basic actions is the maximum reduction of actions (and lines). One of the main actions that can be discarded is object selections and ranges (the blessed ".Select", very common when you record macros). So we have identical results for the following key lines:

'Código sem otimizar
    Range("A1").Select
    Selection.Copy

'Código otimizado
    Range("A1").Copy

Or , one applied to your code:

'Código sem otimizar
    Columns(col).Select
    numRows = Selection.Rows.Count

'Código otimizado
    numRows = Columns(col).Rows.Count

Another thing: since you have two matrices with fixed number of columns (77), why don’t you copy everything at once, instead of repeating the action column by column? In addition, you are working with a very large range of cells (from line 2 to 1,048,576)... do you need this? Anyway, I suggest you.

So I would write all your code as follows:

Sub Percorre()

'Desabilitar recursos desnecessários
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False

'Dimensionar variáveis
    Dim wsOrig, wsDest As Worksheet
    Dim numRows As Long
    Dim PastaAtual, NomeDoArquivo, NomeCompletoDoArquivo, valor As String
    Dim Busca, RangeFrom, RangeTo As Range

'Declarar variáveis na planilha corrente
    Set wsOrig = ThisWorkbook.Worksheets("Aspiradores")
    wsOrig.Activate
    'contar apenas o total de linhas com valor. Caso não haja valor na célula "A1", somar (+1)
    numRows = Application.WorksheetFunction.CountA(Columns(1))
    Set RangeFrom = Range(Cells(2, 1).Value, Cells(numRows, 77))
    valor = RangeFrom.Cells(1).Value

'Abrir planilha destino e declarar variáveis
    PastaAtual = ThisWorkbook.Path
    NomeDoArquivo = "teste.xlsx"
    NomeCompletoDoArquivo = PastaAtual & "\" & NomeDoArquivo
    Set wsDest = Workbooks.Open(NomeCompletoDoArquivo).ActiveSheet
    wsDest.Activate
    'Encontrar endereço da célula buscada
    Set Busca = Cells.Find(What:=valor, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Address
    Set RangeTo = Range(Busca, Busca.Offset(numRows, 77))
    RangeTo.Value = RangeFrom.Value

'Restaurar recursos desabilitados
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayAlerts = True

End Sub

Answer 2

If the columns are in different order, the code would have to make a loop even, from column to column:

Sub Percorre()

'Desabilitar recursos desnecessários
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False

'Dimensionar variáveis
    Dim wsOrig, wsDest As Worksheet
    Dim numRows As Long
    Dim PastaAtual, NomeDoArquivo, NomeCompletoDoArquivo, valor As String
    Dim Busca, RangeFrom, RangeTo As Range

'Declarar variáveis na planilha corrente
    Set wsOrig = ThisWorkbook.Worksheets("Aspiradores")
    wsOrig.Activate
    'contar apenas o total de linhas com valor. Caso não haja valor na célula "A1", somar (+1)
    numRows = Application.WorksheetFunction.CountA(Columns(1))
    Set RangeFrom = wsOrig.Range(Cells(2, 1).Value, Cells(numRows, 77))

'Abrir planilha destino e declarar variáveis
    PastaAtual = ThisWorkbook.Path
    NomeDoArquivo = "teste.xlsx"
    NomeCompletoDoArquivo = PastaAtual & "\" & NomeDoArquivo
    Set wsDest = Workbooks.Open(NomeCompletoDoArquivo).ActiveSheet
    wsDest.Activate
    wsDest.Cells(1, 1).Select

'Loop para cópia de colunas 1 a 1
    Dim n As Integer: n = 1
    Do While RangeFrom.Cells(1, n) <> vbNullString
        valor = RangeFrom.Cells(1, n).Value
        Set Busca = Cells.Find(What:=valor, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Address
        Set RangeTo = Range(Busca, Busca.Offset(RangeFrom.Rows.Count - 1, 0))
        RangeTo.Value = RangeFrom.Columns(n).Value
        n = n + 1
        Loop

'Restaurar recursos desabilitados
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayAlerts = True

End Sub