none
Rotina não executa RRS feed

  • Pergunta

  • Boa tarde pessoas,

    Elaborei uma macro que deve incrementar uma planilha existente. Esta faza tudo perfeitamente, quase tudo, deleta a base antiga, importa a nova, e acrescenta o items pedidos nas posições corretas.

    Porém não executa determinado loop que deve preencher alguns espaços vazios. Não execulta quando mando execultar(jura...) a macro. Mas quando testo linha a linha, utilizando F8, a rotina funciona normalmente, alguem pode me ajudar a descobrir o que há de errado?

    Segue o código:

    Sub add()
    Application.ScreenUpdating = False
    '-------Deleta BASE antiga e abre nova---------
        Sheets("Base").Delete
        Sheets.add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Select
        Sheets(Sheets.Count).Name = "Base"
        Dim linha As Variant
        Dim w As Long
        Dim arquivo As String
        arquivo = Application.GetOpenFilename("(*.txt),*.txt")
        Open arquivo For Input As #1
        w = 1
        While Not EOF(1)
            Line Input #1, linha
            Cells(w, 1).Value = linha
            w = w + 1
        Wend
        Columns("A:A").Select
        Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
            :="=", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
        Close #1
        Columns("A:B").EntireColumn.AutoFit
        Range("A1").Select
    '-------Determina tamanho da nova base-------
        Dim tam As Integer
        Dim wsBase As Worksheet
        Set wsBase = Sheets("Base")
        tam = wsBase.Cells.SpecialCells(xlCellTypeLastCell).Row
    '--------Determina tamanho da lista desatualizada-------
        Dim wsSfpnew As Worksheet
        Set wsSfpnew = Sheets("SFP")
        Dim j As Long
        Dim l As Long
        Dim i As Long
        l = wsSfpnew.Cells.SpecialCells(xlCellTypeLastCell).Row
        i = l + 1
    '---------Acrescenta dados--------
        For j = 1 To tam
            With Worksheets("Base").Cells(j, "A")
                If InStr(.Value, "NE:") > 0 Then
                    Sheets("SFP").Cells(l, "A") = .Value
                ElseIf InStr(.Value, "Board:") > 0 Then
                   Sheets("SFP").Cells(l, "B") = .Value
                ElseIf InStr(.Value, "Main") > 0 Then
                    Sheets("SFP").Cells(l, "C") = .Value
                ElseIf InStr(.Value, "Port") > 0 Then
                    Sheets("SFP").Cells(l, "C") = .Value
                ElseIf InStr(.Value, "BoardType") > 0 Then
    
                    Sheets("SFP").Cells(l, "D") = .Offset(0, 1).Value
                ElseIf InStr(.Value, "BarCode") > 0 Then
                    Sheets("SFP").Cells(l, "E") = .Offset(0, 1).Value
                ElseIf InStr(.Value, "Item") > 0 Then
                    Sheets("SFP").Cells(l, "F") = .Offset(0, 1).Value
                ElseIf InStr(.Value, "Description") > 0 Then
                    Sheets("SFP").Cells(l, "G") = .Offset(0, 1).Value
                End If
                l = l + 1
            End With
        Next j
    '---------Determina tamanho da lista atualizada---------
        Dim tam2 As Long
        Dim wsSFP As Worksheet
        Set wsSFP = Sheets("SFP")
        tam2 = wsSFP.Cells.SpecialCells(xlCellTypeLastCell).Row
        Dim k As Long
        'sms = MsgBox("Tam2 = " & tam2, vbOKOnly)
        'sms = MsgBox("i = " & i, vbOKOnly)
    '---------Preenche espaços vazios das atualizações--------
        For k = 1 To 2
            With Worksheets("SFP")
                For j = i To tam2
                    Do While IsEmpty(Cells(j, k)) = True And IsEmpty(Cells(j - 1, k)) = False
                        Cells(j - 1, k).Copy (Cells(j, k))
                    Loop
                Next j
            End With
        Next k
        Sheets("SFP").Select
        Columns("A:G").EntireColumn.AutoFit
        Application.ScreenUpdating = True
    End Sub
    Agradeço muitíssimo a ajuda.

    quarta-feira, 5 de dezembro de 2012 16:09

Respostas

  • Então, o problema de executar parte do código eu resolvi, reescrevendo e pensando em outra logica para aquela parte. Não sei te dizer exatamente se é OpenText ou não, parte desse codigo foi feito com gravação de macro e especificamente esta parte que citou eu adaptei de um outro forum que achei na rede. Só sei te dizer que por algum motivo, sem essa parte, nenhuma das rotinas, seja a geradora, seja a que adiciona elementos funciona. Não importava sem essa parte.

    Criei ponto de interrupção no meu código antes mesmo de abrir esta Thread, e como eu disse acima, a rotina simplesmente pulava certas linhas do codigo.

    Enfim, agradeço a resposta.


    Sub add()
    Application.ScreenUpdating = False
    '-------Deleta BASE antiga e abre nova---------
        Sheets("Base").Delete
        Sheets.add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Select
        Sheets(Sheets.Count).Name = "Base"
        Dim linha As Variant
        Dim w As Long
        Dim arquivo As String
        arquivo = Application.GetOpenFilename("(*.txt),*.txt")
        Open arquivo For Input As #1
        w = 1
        While Not EOF(1)
            Line Input #1, linha
            Cells(w, 1).Value = linha
            w = w + 1
        Wend
        Columns("A:A").Select
        Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
            :="=", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
        Close #1
        Columns("A:B").EntireColumn.AutoFit
        Range("A1").Select
    '-------Determina tamanho da nova base-------
        Dim tam As Integer
        Dim wsBase As Worksheet
        Set wsBase = Sheets("Base")
        tam = wsBase.Cells.SpecialCells(xlCellTypeLastCell).Row
    '--------Determina tamanho da lista desatualizada-------
        Dim wsSFP As Worksheet
        Set wsSFP = Worksheets("SFP")
        Dim j As Long
        Dim v As Long
        Dim i As Integer
        Dim n As Integer
        Dim LRow&
        With wsSFP
            Let LRow& = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        End With
        v = LRow&
        i = v + 1
        n = i
    '---------Acrescenta dados--------
        For j = 1 To tam
            With Worksheets("Base").Cells(j, "A")
                If InStr(.Value, "NE:") > 0 Then
                    Sheets("SFP").Cells(i, "A") = .Value
                ElseIf InStr(.Value, "Board:") > 0 Then
                   Sheets("SFP").Cells(i - 1, "B") = .Value
                ElseIf InStr(.Value, "Main") > 0 Then
                    Sheets("SFP").Cells(i - 2, "C") = .Value
                ElseIf InStr(.Value, "Port") > 0 Then
                    Sheets("SFP").Cells(i - 2, "C") = .Value
                ElseIf InStr(.Value, "BoardType") > 0 Then
                    If IsEmpty(Sheets("SFP").Cells(i - 4, "C")) = True Then
                        Sheets("SFP").Cells(i - 3, "D") = .Offset(0, 1).Value
                    Else
                        Sheets("SFP").Cells(i - 4, "D") = .Offset(0, 1).Value
                    End If
                ElseIf InStr(.Value, "BarCode") > 0 Then
                    If IsEmpty(Sheets("SFP").Cells(i - 5, "C")) = True Then
                        Sheets("SFP").Cells(i - 4, "E") = .Offset(0, 1).Value
                    Else
                        Sheets("SFP").Cells(i - 5, "E") = .Offset(0, 1).Value
                    End If
                ElseIf InStr(.Value, "Item") > 0 Then
                    If IsEmpty(Sheets("SFP").Cells(i - 6, "C")) = True Then
                        Sheets("SFP").Cells(i - 5, "F") = .Offset(0, 1).Value
                    Else
                        Sheets("SFP").Cells(i - 6, "F") = .Offset(0, 1).Value
                    End If
                ElseIf InStr(.Value, "Description") > 0 Then
                    If IsEmpty(Sheets("SFP").Cells(i - 7, "C")) = True Then
                        Sheets("SFP").Cells(i - 6, "G") = .Offset(0, 1).Value
                    Else
                        Sheets("SFP").Cells(i - 7, "G") = .Offset(0, 1).Value
                    End If
                End If
                i = i + 1
            End With
        Next j
    '---------Determina tamanho da lista atualizada---------
        Dim tam2 As Integer
        tam2 = wsSFP.Cells.SpecialCells(xlCellTypeLastCell).Row
        Dim k As Long
    '-------Deleta linhas brancas--------
        With Worksheets("SFP")
            Do While tam2 <> n
                If IsEmpty(.Cells(tam2, 7)) = True Then
                    .Rows(tam2).Delete
                    tam2 = tam2 - 1
                Else
                    tam2 = tam2 - 1
                End If
            Loop
        End With
    '---------Preenche espaços vazios das atualizações--------
        Dim tam3 As Long
        Dim LR As Long
        With Worksheets("SFP")
            Let LR = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        End With
        tam3 = LR
        j = n + 1
        For k = 1 To 2
            With Worksheets("SFP")
                Do While j <= tam3
                    If IsEmpty(.Cells(j, k)) = True And IsEmpty(.Cells(j - 1, k)) = False Then
                        .Cells(j - 1, k).Copy Destination:=.Cells(j, k)
                        j = j + 1
                    Else
                        j = j + 1
                    End If
                Loop
            End With
            j = n + 1
        Next k
    '------------------FIM--------------------
        Sheets("SFP").Select
        Columns("A:G").EntireColumn.AutoFit
        Application.ScreenUpdating = True
    End Sub
    
    

    segunda-feira, 10 de dezembro de 2012 15:15

Todas as Respostas

  • *O correto é executar.

    Tem algumas coisas em seu código que não estou entendendo. Por exemplo, para que serve o bloco de código abaixo?

     Dim linha As Variant
        Dim w As Long
        Dim arquivo As String
        arquivo = Application.GetOpenFilename("(*.txt),*.txt")
        Open arquivo For Input As #1
        w = 1
        While Not EOF(1)
            Line Input #1, linha
            Cells(w, 1).Value = linha
            w = w + 1
        Wend

    Você está importando os dados através do método OpenText, não é necessária essa parte.

    Desconfio que pelo fato de você estar usando o método Select (de planilha e célula) você está tendo estes problemas.

    Crie pontos de interrupção com a tecla F9 em seu código para ver onde o código pára de executar.



    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    sexta-feira, 7 de dezembro de 2012 20:50
    Moderador
  • Então, o problema de executar parte do código eu resolvi, reescrevendo e pensando em outra logica para aquela parte. Não sei te dizer exatamente se é OpenText ou não, parte desse codigo foi feito com gravação de macro e especificamente esta parte que citou eu adaptei de um outro forum que achei na rede. Só sei te dizer que por algum motivo, sem essa parte, nenhuma das rotinas, seja a geradora, seja a que adiciona elementos funciona. Não importava sem essa parte.

    Criei ponto de interrupção no meu código antes mesmo de abrir esta Thread, e como eu disse acima, a rotina simplesmente pulava certas linhas do codigo.

    Enfim, agradeço a resposta.


    Sub add()
    Application.ScreenUpdating = False
    '-------Deleta BASE antiga e abre nova---------
        Sheets("Base").Delete
        Sheets.add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Select
        Sheets(Sheets.Count).Name = "Base"
        Dim linha As Variant
        Dim w As Long
        Dim arquivo As String
        arquivo = Application.GetOpenFilename("(*.txt),*.txt")
        Open arquivo For Input As #1
        w = 1
        While Not EOF(1)
            Line Input #1, linha
            Cells(w, 1).Value = linha
            w = w + 1
        Wend
        Columns("A:A").Select
        Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
            :="=", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
        Close #1
        Columns("A:B").EntireColumn.AutoFit
        Range("A1").Select
    '-------Determina tamanho da nova base-------
        Dim tam As Integer
        Dim wsBase As Worksheet
        Set wsBase = Sheets("Base")
        tam = wsBase.Cells.SpecialCells(xlCellTypeLastCell).Row
    '--------Determina tamanho da lista desatualizada-------
        Dim wsSFP As Worksheet
        Set wsSFP = Worksheets("SFP")
        Dim j As Long
        Dim v As Long
        Dim i As Integer
        Dim n As Integer
        Dim LRow&
        With wsSFP
            Let LRow& = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        End With
        v = LRow&
        i = v + 1
        n = i
    '---------Acrescenta dados--------
        For j = 1 To tam
            With Worksheets("Base").Cells(j, "A")
                If InStr(.Value, "NE:") > 0 Then
                    Sheets("SFP").Cells(i, "A") = .Value
                ElseIf InStr(.Value, "Board:") > 0 Then
                   Sheets("SFP").Cells(i - 1, "B") = .Value
                ElseIf InStr(.Value, "Main") > 0 Then
                    Sheets("SFP").Cells(i - 2, "C") = .Value
                ElseIf InStr(.Value, "Port") > 0 Then
                    Sheets("SFP").Cells(i - 2, "C") = .Value
                ElseIf InStr(.Value, "BoardType") > 0 Then
                    If IsEmpty(Sheets("SFP").Cells(i - 4, "C")) = True Then
                        Sheets("SFP").Cells(i - 3, "D") = .Offset(0, 1).Value
                    Else
                        Sheets("SFP").Cells(i - 4, "D") = .Offset(0, 1).Value
                    End If
                ElseIf InStr(.Value, "BarCode") > 0 Then
                    If IsEmpty(Sheets("SFP").Cells(i - 5, "C")) = True Then
                        Sheets("SFP").Cells(i - 4, "E") = .Offset(0, 1).Value
                    Else
                        Sheets("SFP").Cells(i - 5, "E") = .Offset(0, 1).Value
                    End If
                ElseIf InStr(.Value, "Item") > 0 Then
                    If IsEmpty(Sheets("SFP").Cells(i - 6, "C")) = True Then
                        Sheets("SFP").Cells(i - 5, "F") = .Offset(0, 1).Value
                    Else
                        Sheets("SFP").Cells(i - 6, "F") = .Offset(0, 1).Value
                    End If
                ElseIf InStr(.Value, "Description") > 0 Then
                    If IsEmpty(Sheets("SFP").Cells(i - 7, "C")) = True Then
                        Sheets("SFP").Cells(i - 6, "G") = .Offset(0, 1).Value
                    Else
                        Sheets("SFP").Cells(i - 7, "G") = .Offset(0, 1).Value
                    End If
                End If
                i = i + 1
            End With
        Next j
    '---------Determina tamanho da lista atualizada---------
        Dim tam2 As Integer
        tam2 = wsSFP.Cells.SpecialCells(xlCellTypeLastCell).Row
        Dim k As Long
    '-------Deleta linhas brancas--------
        With Worksheets("SFP")
            Do While tam2 <> n
                If IsEmpty(.Cells(tam2, 7)) = True Then
                    .Rows(tam2).Delete
                    tam2 = tam2 - 1
                Else
                    tam2 = tam2 - 1
                End If
            Loop
        End With
    '---------Preenche espaços vazios das atualizações--------
        Dim tam3 As Long
        Dim LR As Long
        With Worksheets("SFP")
            Let LR = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        End With
        tam3 = LR
        j = n + 1
        For k = 1 To 2
            With Worksheets("SFP")
                Do While j <= tam3
                    If IsEmpty(.Cells(j, k)) = True And IsEmpty(.Cells(j - 1, k)) = False Then
                        .Cells(j - 1, k).Copy Destination:=.Cells(j, k)
                        j = j + 1
                    Else
                        j = j + 1
                    End If
                Loop
            End With
            j = n + 1
        Next k
    '------------------FIM--------------------
        Sheets("SFP").Select
        Columns("A:G").EntireColumn.AutoFit
        Application.ScreenUpdating = True
    End Sub
    
    

    segunda-feira, 10 de dezembro de 2012 15:15
  • Reescreva o código sem utilizar os métodos Select e Activate. Você consegue?

    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    segunda-feira, 10 de dezembro de 2012 21:31
    Moderador