Excel VBA with Array's slow taratar data

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 the "layout" by it. 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 verify the code and to be able to explain to me where I can improve and in what form. 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
    
asked by anonymous 25.06.2018 / 03:23

0 answers