Rotina não executa

Question

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.

Answer 1

*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

Answer 2

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

Answer 3

Reescreva o código sem utilizar os métodos Select e Activate. Você consegue?

---

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