宏崩溃的Excel

时间:2019-09-05 23:38:48

标签: excel vba

我需要一个宏,该宏将来自一百个不同工作簿的数据收集到一张纸中。这就是我想出的。可悲的是,当我尝试运行Excel时,它崩溃了,并且没有错误消息显示。

Sub Cop()

Dim lin As Integer
Dim myfolder As String 
Dim myfile As String 
Dim proj As String 
Dim master As Workbook 
Dim controle As Worksheet 
Dim fonte As Worksheet

Set master = ThisWorkbook 
Set controle = master.Worksheets("Controle Meta 2024 - Plus")

lin = 5

myfolder = "R:\2. XYZ\Empresas\ABC\1. Mandato\1. Informações\1. Informações Recebidas\Projeções Lançamentos 2020-2024\DE-PARA"

For i = 1 To 118
    proj = master.Worksheets("Controle Meta 2024 - Plus").Cells(lin, 2)
    myfile = Dir(myfolder & proj & "\*.xlsx")
    On Error GoTo Erro
    Workbooks.Open Filename:=myfile
    Set fonte = Workbooks(myfile).Worksheets("DADOS")
    master.controle.Cells(lin, 70) = Workbooks(myfile).fonte.Range("E7")
    master.controle.Cells(lin, 71) = Workbooks(myfile).fonte.Range("E6")
    Workbooks(myfile).Close SaveChanges:=False
    lin = lin + 1 

Prox:
    Next i 

Erro:
    Resume Prox

End Sub

谢谢!

2 个答案:

答案 0 :(得分:0)

尝试以下代码, 罗恩(Ron)在OnError中隐藏了错误(这就是为什么您没有收到错误消息的原因)

您错误地使用了DIR()函数,请参见下文。而While外观的“ while”循环比“ For”循环更有效

`Sub Cop()
Dim lin As Integer
myfolder As String
Dim myfile As String
Dim proj As String
Dim master As Workbook
Dim controle As Worksheet
Dim fonte As Worksheet

Set master = ThisWorkbook
Set controle = master.Worksheets("Controle Meta 2024 - Plus")

lin = 5

myfolder = "R:\2. XYZ\Empresas\ABC\1. Mandato\1. Informações\1. Informações Recebidas\Projeções Lançamentos 2020-2024\DE-PARA"
myfile = Dir(myfolder & proj & "\*.xlsx")
While myfile <> ""
    proj = master.Worksheets("Controle Meta 2024 - Plus").Cells(lin, 2)
    On Error GoTo Erro
    Workbooks.Open Filename:=myfile
    Set fonte = Workbooks(myfile).Worksheets("DADOS")
    master.controle.Cells(lin, 70) = Workbooks(myfile).fonte.Range("E7")
    master.controle.Cells(lin, 71) = Workbooks(myfile).fonte.Range("E6")
    Workbooks(myfile).Close SaveChanges:=False
    lin = lin + 1
    myfile = Dir()
Prox:
Wend

Erro:
    Resume Prox
End Sub`

答案 1 :(得分:0)

未经测试:

Sub Cop()

    'Use constants for fixed values
    Const MYFOLDER As String = "R:\2. XYZ\Empresas\ABC\1. Mandato\1. Informações\1. " & _
           "Informações Recebidas\Projeções Lançamentos 2020-2024\DE-PARA"

    Dim myfile As String, proj As String, i As Long
    Dim controle As Worksheet, fonte As Worksheet

    Set controle = ThisWorkbook.Worksheets("Controle Meta 2024 - Plus")

    For i = 5 To 123
        proj = controle.Cells(i, 2).Value
        myfile = Dir(MYFOLDER & proj & "\*.xlsx")
        If Len(myfile) > 0 Then '<<< is there a matching file?
            With Workbooks.Open(Filename:=myfile)
                Set fonte = .Worksheets("DADOS")
                controle.Cells(i, 70) = fonte.Range("E7").Value
                controle.Cells(i, 71) = fonte.Range("E6").Value
                .Close SaveChanges:=False
            End With
        End If
    Next i

End Sub