0

estou a desenvolver um código a ser aplicado em excel que faz o resumo do numero de defeitos numa tabela resumo. Os dados são importados de um ficheiro xml, que é aberto pelo excel e criado o "layout" pelo mesmo. Como é a primeira vez que trabalho com array´s e acho o processamento muito lento gostava de saber se é possível verificar o código e poder-me explicar onde posso melhorar e de que forma. Obrigado.

Codigo:

    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
3
  • 2
    Arrays (vetores) são rapidos e são a forma mais otimizada de realizar tarefas no Excel. Você está realizando muitas interações entre o VBA e a planilha Excel e isto é lento. Por exemplo, evite a utilização de .Select, ou a ação de deletar em loop Selection.Delete Shift:=xlUp, que é realizada várias vezes. A melhor forma de deletar é criar uma Range não contígua, ou filtrar para os dados que você deseja e realizar a ação de deletar somente uma vez. Commented 25/06/2018 às 13:12
  • Antes de mais obrigado, eu tentei definir um array com as variáveis de linha e coluna, mas o mesmo dá-me erro nessa altura. Como não sei outra forma de ultrapassar essa situação fiz todo este código. Pode-me dizer como posso fazer algo: myarray(linha,coluna) *- Tendo os valores em variaveis? Obrigado
    – Pedro Lima
    Commented 25/06/2018 às 23:00
  • Veja esta resposta que possui uma maneira de popular a array com valores de células. Commented 26/06/2018 às 0:08

0

Você deve fazer log-in para responder a esta pergunta.

Pesquise outras perguntas com a tag .