none
VBA - Abrir multiplos ficheiros Excel (path listados em células) e executar ações RRS feed

  • Pergunta

  • Bom dia,

    Preciso de ajuda para fazer o loop das seguintes tarefas em diversos ficheiros excel cujos paths tenho listados numa tabela nas células D42 a D83 da folha "Ficha de funcionario".

    Este código VBA funciona para a primeira célula D42, indicando:

    Dim myfile As String
    
    myfile = Cells(42, 4).Value
    
    Application.Workbooks.Open Filename:=myfile
    


    Como indico que pretendo executar para os restantes ficheiros de D43 a D83? E se alguma célula estiver vazia (sem path), como digo para ignorar?

    Obrigada pela ajuda!! e bom ano !!

    O código completo é:

    Sub Importar_registos_tempos_individuais()
    '
    ' Importar_registos_tempos_individuais Macro
    '
    
    Dim mes As String
    mes = Workbooks("Mapa Registo Tempos_total_V6.xlsm").Worksheets("Registo Tempos").Range("F3").Value
    
    Dim ano As String
    ano = Workbooks("Mapa Registo Tempos_total_V6.xlsm").Worksheets("Registo Tempos").Range("F2").Value
    
    Sheets("Ficha de funcionario").Select
    
    'Open Excel files
    
    Dim myfile As String
    
    myfile = Cells(42, 4).Value
    
    Application.Workbooks.Open Filename:=myfile
    
     
      'Unprotect a worksheet
    
    Sheets("Histórico").Select
    Sheets("Histórico").Unprotect
    
    'Criar colunas Ano e Mês e Autofilter
    
        Range("K8").Select
        ActiveCell.FormulaR1C1 = "Ano"
        Range("L8").Select
        ActiveCell.FormulaR1C1 = "Mês"
        Range("K9").Select
        Application.CutCopyMode = False
        ActiveCell.FormulaR1C1 = "=YEAR(RC[-10])"
        Range("L9").Select
        ActiveCell.FormulaR1C1 = "=MONTH(RC[-11])"
        Range("K9:L9").Select
        Selection.Copy
        Range("A8").Select
        Selection.End(xlDown).Select
        ActiveCell.Offset(0, 10).Range("A1:B1").Select
        Range(Selection, Selection.End(xlUp)).Select
        
        ActiveSheet.Paste
        Selection.End(xlUp).Select
        ActiveCell.Offset(0, 1).Range("A1").Select
        Application.CutCopyMode = False
        Selection.AutoFilter
        Selection.AutoFilter
        ActiveSheet.Range("$A$8:$L$19999").AutoFilter Field:=11, Criteria1:=ano
        ActiveSheet.Range("$A$8:$L$19999").AutoFilter Field:=12, Criteria1:=mes
    
        
    'Copy
           
    
        Range("A8").Select
        ActiveCell.Offset(12, 0).Range("A1").Select
        Range(Selection, Selection.End(xlDown)).Select
        ActiveCell.Range("A1:J1000").Select
        Selection.Copy
    
    
        
    'Paste
    
    ThisWorkbook.Activate
    
    Sheets("Registo Tempos").Select
        Range("D10").Select
        Selection.End(xlDown).Select
        ActiveCell.Offset(1, 0).Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
    
      'Save but not save changes
    
    Dim wb As Workbook
    
      'Loop through each workbook
      For Each wb In Application.Workbooks
        
        'Prevent the workbook that contains the
        'code from being closed
        If wb.Name <> ThisWorkbook.Name Then
          
          'Close the workbook and don't save changes
          wb.Close SaveChanges:=False
        
        End If
      Next wb
      
    End Sub
    
    

    segunda-feira, 31 de dezembro de 2018 12:43

Todas as Respostas

  • Olá, boa tarde.

    Você pode fazer algo do tipo:

    Dim i As Long
    
    For i = 42 To 83
    
        myfile = Cells(i, 4).Value2
        
        If myfile <> vbNullString Then
        
            If Dir(myfile, vbNormal + vbReadOnly + vbHidden) <> vbNullString Then
                
                Application.Workbooks.Open Filename:=myfile
                
                '...
                'Seu código
                '...
                
            End If
        End If
    Next i

    Atende?


    Filipe Magno

    terça-feira, 1 de janeiro de 2019 19:51