Optimization in VBA code?

Question

Optimization in VBA code?

Navigation

#1 by (2 votes)
#2 by (1 votes)

3

I have two spreadsheets, both have the same header, with 77 columns. For test I put 4 rows 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 worksheet that has only the header, however, so that this macro finalizes the copy to the other worksheet takes approximately 30 minutes. Since the purpose is to optimize a manual process, in which there will be much more than 4 lines of data filled, the macro will become unfeasible 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

excel vba

asked by anonymous 22.02.2017 / 19:08

2 answers

How to get the total percentage and individual and per field in ASP Classico Calculation of the Shannon entropy in a network traffic (saved in CAP file) using Python

score 2 · 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 intervals (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, not 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 arrays with a fixed number of columns (77), why do not you copy everything at once instead of repeating the column-by-column action? Also, you're working with a very large range of cells (from line 2 up 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

score 1 · Answer 2

If the columns are in different order, the code would have to 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