0
I am developing a code to be applied in excel that summarizes the number of defects in a summary table. The data is imported from an xml file, which is opened by excel and created "layout" by excel. As it is the first time I work with array s and I find the processing very slow I would like to know if it is possible to check the code and explain to me where I can improve and how. Thank you.
Code:
Sub importXMLS()
' Declaração de variaveis e condições iniciais
'_____________________________________________________
Dim wb As Workbook
Dim TheFile As String
Dim instance As XPath
Dim Map As XmlMap
Dim XPath As String
Dim Book As String
Dim Book1 As String
Dim lig As Long
Dim comp As Single
Dim comp1 As Single
Dim DLig As Long
Dim Lote As String
Dim xmls As String
Dim opcao As String
Dim file As String
Dim oSh As Worksheet
Dim oLo As ListObject
Dim Col As String
Dim Lin As String
Dim BCol As String
Dim BLin As String
Dim Hed As String
Dim Flag As String
Dim Mult As String
Dim zero As String
Dim Col1 As Long
Dim Lin1 As String
Dim Coluna As Long
Dim Linha As Long
Dim index As String
Dim fila As Long
Dim columna As Long
Dim MyArray() As Variant
zero = 0
comp = 0 ' Colocar comprimento a zero
' Não actualizar ecra/mostrar alertas e guardar nome do excel
'_____________________________________________________
Application.DisplayAlerts = False ' Não apresenta alertas
Application.ScreenUpdating = False ' Não actualiza o ecrã
Livro = ActiveWindow.Caption ' Guarda o nome do EXCEL PRINCIPAL
' Elimina o conteudo da aba Table
'_____________________________________________________
Windows(Livro).Activate ' Activa o Excel principal
Sheets("Table").Select ' Seleciona a aba Table
Range("A2").Select ' Seleciona a celula A2
If IsEmpty(ActiveCell) = False Then ' Se não está vazia, então
Rows("2:1048575").Select ' Seleciono todas as linhas
Selection.ClearContents ' Elimina toda a informação
Range("A2").Select ' Seleciona a celula A2
End If
' Directório pre definido dos ficheiros XML e modo de funcionamento
'_____________________________________________________
Sheets("Parametros").Select ' Seleciona a aba Defects-list
xmls = Range("B3").Value ' Variavel Caminho Xmls
impor = Range("B6").Value ' Variavel xmls depois de importados
vazio = Range("B9").Value ' Variavel xmls sem defeitos
opcao = Range("F6").Value ' Variavel de modo de funcionamento
If opcao = "1" Then ' Testa se modo de funcionamento
'ChDir xmls ' Selecionar Xmls
n1 = 0
n2 = 0
' Selecionar e importa XMLS
'_____________________________________________________
filetoopen = Application _
.GetOpenFilename("XML Files (*.xml), *.xml", , "Import XML", , True) ' selecionar xmls
Application.DisplayAlerts = True ' Alertas ON
If IsArray(filetoopen) Then
For Each fil In filetoopen
file = Right(fil, 12) ' Nome XML
Set wb = Workbooks.OpenXML(Filename:=fil, LoadOption:=xlXmlLoadImportToList)
Book = ActiveWindow.Caption ' guarda o nome do excel temporario
Book1 = ActiveSheet.Name ' guardar o nome da folha temporaria
' Testa se ficheiro não tem defeitos
'_____________________________________________________
Windows(Book).Activate ' Activa ficheiro temporario
Worksheets(Book1).Range("A2").Activate ' Seleciona a Celula A2
If IsEmpty(ActiveCell) = True Then ' Testar se o rolo está vazio
Application.DisplayAlerts = False ' Desativo os alertas
ActiveWindow.Close
Application.DisplayAlerts = True ' Activa os alertas
n1 = n1 + 1
Else
n2 = n2 + 1
Windows(Livro).Activate ' Activa o excel import XML
Sheets("Table").Select ' Seleciona a Folha Table
Range("A2").Select ' Seleciona celula 2
Windows(Book).Activate ' Activa ficheiro temporario
comp = Worksheets(Book1).Range("F2").Value ' Seleciona o comprimento
Worksheets(Book1).Range("A2").Activate ' Seleciona a Celula A2
Range("A2", Range("AK2").End(xlDown)).Select ' Qual a ultima linha a vazia com inicio em A2
Selection.Copy ' Copia seleccao anterior
Windows(Livro).Activate ' Muda para excel principal
Worksheets("Table").Range("A2").Activate ' Seleciono a 1a linha vazia
ActiveSheet.Paste ' Colo a seleccao
Windows(Book).Activate ' Activo o excel temporario
Application.DisplayAlerts = False ' Desativo os alertas
ActiveWindow.Close ' Fecho o excel temporario
Windows(Livro).Activate ' Activo excel principal
Range("A2").Select ' Seleciono a 1a Celula dessa linha
End If
Windows(Livro).Activate ' Activa o excel principal
Sheets("Menu").Select
Range("A13").Select
' End If
Next fil
Else
Exit Sub
End If
End If
'_____________________________________________________
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Sheets("Table").Select ' Seleciona a aba Menu
ID = Range("A2")
style = Range("E2")
Start = Range("C2")
Tend = Range("D2")
DWidth = Range("K2")
Lenght = Range("F2")
DNumber = Range("M2")
Inspec = Range("B2")
Sheets("Menu").Select ' Activa Folha Rolls list
Range("B4") = ID
Range("B5") = style
Range("B6") = Start
Range("B7") = Tend
Range("G4") = DWidth
Range("G5") = Lenght
Range("G6") = DNumber
Range("G7") = Inspec
Sheets("Parametros").Select ' Seleciona a aba Defects-list
Col = Range("G19").Value ' Variavel Colunas
Flag = Col
Mult = 1
Col1 = Col
Lin = Range("G20").Value ' Variavel Linhas'
Lin1 = Lin
BCol = Range("G15").Value ' Banda Colunas
BLin = Range("G16").Value ' Banda Linhas
zero = 0
ind = 2
ind1 = 2
Sheets("Table").Select ' Seleciona a aba Table
DLin = Range("C1").End(xlDown).Row
Hed = Range("K2").Value ' Seleciona a celula K2
comp = Range("F2").Value
' Efectuar os calculos
'___________________________________________________________________
Sheets("Teste1").Select ' Seleciona a aba Table
Set oSh = ActiveSheet
Range("A1").Select ' Seleciona a celula A10
' Cria a tabela de acordo com as linhas e colunas
'_____________________________________________________
For Each oLo1 In oSh.ListObjects
Application.Goto oLo1.Range
oLo1.Delete
Application.CutCopyMode = False
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1"), , xlNo).Name = "Tabela3"
'criar a matriz
Col = Col1
Lin = Lin1
Range("A1").Select
Do While Col > "1" ' cria as colunas
Col = Col - 1
Selection.ListObject.ListColumns.Add
Loop
Do While Lin > "0" ' Cria as linhas
Lin = Lin - 1
Selection.ListObject.ListRows.Add AlwaysInsert:=True
Loop
Range("A1").Select ' Seleciona a celula A10
ActiveSheet.ListObjects("Tabela3").ShowHeaders = False
Range("A1").Value = zero
Flag1 = Lin1
test1 = ActiveCell.Address
Do While Flag1 <> "0"
test = ActiveCell.Address
Range(test).Value = zero
Flag = Col1
Do While Flag > "1"
ActiveCell.Offset(0, 1).Select
test = ActiveCell.Address
Range(test).Value = zero
Flag = Flag - 1
Loop
Range(test1).Select
ActiveCell.Offset(1, 0).Select
test1 = ActiveCell.Address
Flag1 = Flag1 - 1
Loop
Rows("1:1").Select
Selection.Delete Shift:=xlUp
' copiar tabela para array
Range("A1").Select
MyArray = Range("A1").CurrentRegion
Flag1 = DLin
Do While Flag1 > "1"
Sheets("Table").Select
testar = Range("AH" & ind).Value
Coluna = Application.RoundUp((testar / BCol), 0)
ind = ind + 1
testar1 = Range("AG" & ind1).Value
Linha = Application.RoundUp((testar1 / BLin), 0)
ind1 = ind1 + 1
Flag1 = Flag1 - 1
Sheets("Teste1").Select
MyArray(Linha, Coluna) = MyArray(Linha, Coluna) + 1
Sheets("Teste1").Select
Loop
Range("A1").CurrentRegion = MyArray
Range("A1:G1").Select
Next
Col = Col1
Lin = Lin1
Sheets("Menu").Select ' Seleciona a aba Table
Set oSh = ActiveSheet
Range("A10").Select ' Seleciona a celula A10
' Cria a tabela de acordo com as linhas e colunas
'_____________________________________________________
For Each oLo In oSh.ListObjects
Application.Goto oLo.Range
oLo.Delete
Application.CutCopyMode = False
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$10"), , xlNo).Name = "Tabela2"
Range("A10").Select ' Seleciona a celula A10
Do While Col > "0" ' cria as colunas
Col = Col - 1
Selection.ListObject.ListColumns.Add
Loop
Do While Lin > "0" ' Cria as linhas
Lin = Lin - 1
Selection.ListObject.ListRows.Add AlwaysInsert:=True
Loop
Range("A10").Select ' Seleciona a celula A10
Range("A10").Value = "Meter"
Flag = Col1
Do While Flag <> "0" ' Escreve o cabecalho
ActiveCell.Offset(0, 1).Select
test = ActiveCell.Address
Hed1 = BCol * Mult
Range(test).Value = Hed1
Flag = Flag - 1
Mult = Mult + 1
Loop
Range("A10").Select ' Seleciona a celula A10
Mult = 1
Flag1 = Lin1
Do While Flag1 <> "0"
ActiveCell.Offset(1, 0).Select
test = ActiveCell.Address
test1 = ActiveCell.Address
Hed1 = BLin * Mult
Range(test).Value = Hed1
Flag1 = Flag1 - 1
Mult = Mult + 1
Flag = Col1
Range(test1).Select
Loop
Next
Sheets("Teste1").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Menu").Select
Range("B11").Select
ActiveSheet.Paste
Range("A1").Select
Sheets("Teste1").Select
Rows("1:1048575").Select ' Seleciono todas as linhas
Selection.ClearContents ' Elimina toda a informação
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1"), , xlNo).Name = "Tabela3"
Range("A2").Select ' Seleciona a celula A2
Sheets("Menu").Select
Range("A10").Select
' Do While Flag <> "0" ' Escreve o cabecalho
' ActiveCell.Offset(0, 1).Select
' test = ActiveCell.Address
' Hed1 = BCol * Mult
' Range(test).Value = Hed1
' Flag = Flag - 1
' Mult = Mult + 1
' Loop
End Sub
Arrays (vectors) are fast and are the most optimized way to perform tasks in Excel. You are performing many interactions between the VBA and the Excel spreadsheet and this is slow. For example, avoid the use of .Select, or the action of loop deleting
Selection.Delete Shift:=xlUp, which is performed several times. The best way to delete is to create a non-contiguous Range, or filter for the data you want and perform the delete action only once.– danieltakeshi
First of all thank you, I tried to define an array with the row and column variables, but the same gives me error at that time. Since I don’t know any other way to overcome that situation, I did all this code. Can you tell me how to do something: myarray(row, column) *- Having values in variables? Thank you
– Pedro Lima
Behold this answer which has a way to popular the array with cell values.
– danieltakeshi