none
VBA - COPIAR PLANILHAS DE VARIOS ARQUIVOS EXCEL RRS feed

  • Pergunta

  • Olá Pessoal, 
    Estou criando um VBA onde eu tenho em um diretório 30 arquivos de Excel onde nele tem uma Plan chamada Tabela de Dados, preciso compilar essa tabela de dados dos 30 arquivos em um só, como uma lista de dados um abaixo do outro.

    Fiz o codigo abaixo e funcionou para 1 arquivo, mas apartir do segundo não estou conseguindo identificaro motivo que ele nao pega os dados.


    Fico agradecido se puderem avaliar e me ajudar.

    Sub lsUnificarPlanilhas()

      Dim lUltimaLinhaAtiva As Long
      Dim lRng As Range
      Dim sPath As String
      Dim fName As String
      Dim lNomeWB As String
      Dim lIPlan As Integer
      Dim lUltimaLinhaPlanDestino As Long

      PlanilhaDestino = ThisWorkbook.Name
      sPath = Localizar_Caminho

        sName = Dir(sPath & "\*.xl*")

      Application.ScreenUpdating = False
      Application.EnableEvents = False
      Application.Calculation = xlCalculationManual

     Do While sName <> ""
            fName = sPath & "\" & sName
            Workbooks.Open Filename:=fName, UpdateLinks:=False

            lNomeWB = ActiveWorkbook.Name

    For lIPlan = 1 To ActiveWorkbook.Sheets.Count




                Workbooks(lNomeWB).Worksheets(lIPlan).Activate

                lUltimaLinhaAtiva = Cells(Rows.Count, 1).End(xlUp).Row
                lUltimaColunaAtiva = ActiveSheet.Cells(1, 5000).End(xlToLeft).Column

                Set lRng = Range(Cells(1, lUltimaColunaAtiva).Address)
                Range("A" & 1 & ":" & gfLetraColuna(lRng) & lUltimaLinhaAtiva).Select
                Selection.Copy

                Workbooks(PlanilhaDestino).Worksheets(1).Activate

                lUltimaLinhaPlanDestino = Cells(Rows.Count, 1).End(xlUp).Row

                If lUltimaLinhaPlanDestino > 1 Then
                    lUltimaLinhaPlanDestino = Cells(Rows.Count, 1).End(xlUp).Row + 1
                End If

                Range("A" & lUltimaLinhaPlanDestino).Select

                ActiveSheet.Paste
                Application.CutCopyMode = False
            Next lIPlan

            Workbooks(lNomeWB).Close SaveChanges:=False
            sName = Dir()
      Loop

      MsgBox "Planilhas unificadas!"


      Application.ScreenUpdating = True
      Application.EnableEvents = True
      Application.Calculation = xlCalculationAutomatic
    End Sub

    Function gfLetraColuna(ByVal rng As Range) As String
        Dim lTexto() As String

        lTexto = Split(rng.Address, "$")

        gfLetraColuna = lTexto(1)
    End Function

    Public Function Localizar_Caminho() As String

        Dim strCaminho As String
        With Application.FileDialog(msoFileDialogFolderPicker)
            'Permitir mais de uma pasta
            .AllowMultiSelect = False

            'Mostrar janela
            .Show

            If .SelectedItems.Count > 0 Then
                strCaminho = .SelectedItems(1)
            End If

        End With

        'Atribuir caminho a variável
        Localizar_Caminho = strCaminho
        End Function

                                                                                                                                                                                                                     
    quarta-feira, 19 de setembro de 2018 14:57