excel – Optimization in VBA code?

Question:

I have two sheets, both have the same header, with 77 columns. For testing I put 4 lines with data filled in one of the tables. In the table with the data filled in, I have the button with the macro, to copy this data to the spreadsheet that has only the header, but for this macro to finish the copy to the other spreadsheet 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 data filled, the macro will become infeasible in this way. Is there a way to optimize the code and reduce this 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:

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 are object and range selections (the blessed ".Select", very common when you record macros). So we have identical results for the following lines of code:

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

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

Or , num 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 a fixed number of columns (77), why don't you copy everything at once instead of repeating the action column by column? Also, you are working with a very large range of cells (from row 2 to 1,048,576)… do you need this? Anyway, I suggest you.

So I would write all your code like this:

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
Post Views: 0
Scroll to Top