Erro de execucao 9 - Subscrito fora do intervalo

Question

Criei uma macro numa planilha consolidadora de dados de várias regiões de minha empresa chamadas DRs. A macro abrir as respectivas planilhas, copiar blocos localizados em abas específicas e, ao finalizar, inclui o trecho a seguir que ativa cada uma das planilhas abertas e as fecha sem salvar. Ao executar o VBA executa a primeira parte (copiar as tabelas), mas apresenta no final da subrotina a mensagem de "Erro de execução '9' - Subscrito fora do intervalo, parando a depuração no comando "Windows(Arq).Activate". Alguém pode indicar o que está errado?

Dim Arq As String

Dim Compl As String  

Compl = ThisWorkbook.Path
Arq = Compl + "\" + "DR_"

DR = Array("03", "04", "05", "06", "08", "10", "12", "14", "16", "18", "20", "22")
i = 0

Do While i < 11
   Arq = Arq + CStr(DR(i)) + ".xlsx"

    Windows(Arq).Activate
    Application.DisplayAlerts = False
    ThisWorkbook.Close
    Application.DisplayAlerts = True

    i = i + 1
    Arq = Compl + "\" + "DR_"

Loop

                

Answer 1

Ao inserir um código no fórum, utilize blocos de código. Para utilizar essa ferramenta, clique no botão cuja legenda é “Inserir bloco de código” na barra do editor de mensagens do fórum. Uma janela aparecerá onde você deverá colar seu código cru na caixa de texto à esquerda. Então, selecione a opção Vb.Net na caixa de combinação que você verá em cima à esquerda e depois clique no botão Inserir.

---

Seu código está dando erro porque não encontra uma janela com o nome da variável "Arq".

Sugiro que acrescente a linha Debug.Print Arq antes da linha Windows(Arq).Activate para ver em qual valor dessa variável sua macro está falhando.

---

http://www.ambienteoffice.com.br - http://www.clarian.com.br

Answer 2

O erro ocorre já na execução do primeiro valor (i = 0) da variável Arq que é 'D:\ArquivosExcel\DR_03.XSLX'. Inicialmente, pensei tratar-se de falha do método Windows(Arq).Activate em reconhecer o valor da variável Arq, dado que o caminho onde estão as planilhas no servidor é muito extenso e com caracteres especiais 'ç' e 'ã'. Aí copiei a pasta para meu micro e continua com o mesmo erro.

Answer 3

Há código faltando na sua macro. Por exemplo: onde está o bloco de código que copia o conteúdo de uma planilha a outra? E o trecho que abre a pasta de trabalho?

Sugiro usar este suplemneto: http://www.rondebruin.nl/win/addins/rdbmerge.htm

---

http://www.ambienteoffice.com.br - http://www.clarian.com.br

Answer 4

Sub Roubo()
'
' Roubo Macro
'
On Error GoTo ErrMsg

Dim Arq As String
Dim i As Integer
Dim chkErro As Integer
Dim Compl As String

'============ Copiar conteúdo das palnilhas das DRs

DR = Array("03", "04", "05", "06", "08", "10", "12", "14", "16", "18", "20", "22", "24", "26", "28", "30", "32", "34", "36", "50", "60", "64", "65", "68", "70", "72", "74", "75")
DRsgl = Array("ACR", "AL", "AP", "AM", "BA", "BSB", "CE", "ES", "GO", "MA", "MG", "MS", "MT", "RO", "PA", "PB", "PE", "PI", "RJ", "RN", "RS", "RR", "SC", "SE", "SPM", "SPI", "TO")


Compl = ThisWorkbook.Path

Arq = Compl + "\" + "DR_"


i = 0
chkErro = 0

Do While i < 2


Arq = Arq + CStr(DR(i)) + ".xlsx"

'
If Dir(Arq) = vbNullString Then
    
    chkErro = 1
    GoTo ErrMsg
    
    Else

    Workbooks.Open Filename:=Arq
    
  
    On Error GoTo ErrMsg
    Sheets("ROUBO").Select
    
    Range("A3:I3").Select

    Range(Selection, Selection.End(xlDown)).Select

    Selection.Copy
    Windows("prejuízos_indenizar_ECT.xlsm").Activate
    Sheets("ROUBO").Select

    Range("A2:A2").Select
    Selection.End(xlDown).Select
    chkErro = 0

End If
        
    If i > 1 Then
    
                  Selection.End(xlDown).Select
    End If
          
         
  
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste



    
ErrMsg:
If chkErro = 1 Then

    MsgBox ("Arquivo da DR " & CStr(DRsgl(i)) & " não localizado ou Aba Roubo inexistente"), , "Mensagem ausência de dados"
    chkErro = 0
End If
    Arq = Compl + "\" + "DR_"

i = i + 1

Loop

'========= Fechar todos os arquivos das DRs ===============

Compl = ThisWorkbook.Path

Arq = Compl + "\" + "DR_"

DR = Array("03", "04", "05", "06", "08", "10", "12", "14", "16", "18", "20", "22", "24", "26", "28", "30", "32", "34", "36", "50", "60", "64", "65", "68", "70", "72", "74", "75")
DRsgl = Array("ACR", "AL", "AP", "AM", "BA", "BSB", "CE", "ES", "GO", "MA", "MG", "MS", "MT", "RO", "PA", "PB", "PE", "PI", "RJ", "RN", "RS", "RR", "SC", "SE", "SPM", "SPI", "TO")

i = 0
chkErro = 0

Do While i < 3


Arq = Arq + CStr(DR(i)) + ".xlsx"

'
If Dir(Arq) = vbNullString Then
    
    chkErro = 1
    GoTo ErrMsg1
    
    Else
    
    MsgBox ("O nome do último arquivo aberto é " & Arq & " o número de ordem é " & i)
    
    Debug.Print Arq
    Windows(Arq).Activate
    Application.DisplayAlerts = False
    ThisWorkbook.Close
    Application.DisplayAlerts = True
    
End If

i = i + 1
    Arq = Compl + "\" + "DR_"
    
ErrMsg1:
    MsgBox ("Arquivo da DR " & CStr(DRsgl(i)) & " não localizado ou Aba Roubo inexistente"), , "Mensagem ausência de dados"
    
Loop

End Sub

Answer 5

Inseri acima todo o código da subrotina. Desculpe não ter feito antes, pois este foi meu primeiro post no Forum.

Answer 6

Sugiro experimentar o código do link que te passei.

---

http://www.ambienteoffice.com.br - http://www.clarian.com.br