Outro Copiar e Colar de Arquivos Diferentes

[viclizz]

Boa tarde, estou precisando de uma ajudinha pra otimizar meu tempo numa criação de dados. O cenário é o seguinte, diariamente uma planilha é criada com dados e salvo com a data do dia, ou seja , existe pasta de cada mês que possui de 30 a 31 planilhas contendo dados. Minha ideia é reunir os dados numa só base. Eu comecei a desenhar algo mas acredito que tenha maneiras mais simples de resolver. Além dessa copia e cola , eu necessito da planilha origem apenas 4 colunas ate a ultima linha preenchida, e na planilha destino a colagem deverá ser feita uma linha depois da ultima linha preenchida ou ate a linha que não esta vazia. 

Já vi alguns fóruns sobre copia e cola porém meu "problema" é que o nome do meu arquivo origem é por data do dia e a ideia da macro e justamente rodar diariamente e juntar todas as informações no fim do mês e não precisar abrir planilha por planilha.

[Basole]

Envie amostras de arquivos que quer importar os dados e o arquivo que receberá 

[viclizz]

esses são so nomes do arquivos origens que desejo copiar os dados! 

 

 

 

e o destino é um arquivo taxas que terá tudo copilado pra fácil manuseio. 

[Basole]

De acordo com as informações passadas e as imagens, segue um exemplo

 

*Copie e cole o codigo abaixo em um modulo padrão na sua pasta de trabalho Destino.

 

Sub Copiar_e_Colar_de_Arquivos_Diferentes()
 'Por Basole 01/08/19
Dim Filename  As String
Dim sDia       As Single
Dim sMes       As String
Dim xlCopy    As Single
Dim fldr      As FileDialog
Dim sItem     As String
    
On Error GoTo Erro

Excel.Application.ScreenUpdating = False
 
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Selecione a Pasta que Deseja Copiar os Arquivos"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then Exit Sub
        sItem = .SelectedItems(1)
    End With

  sMes = InputBox("No formato Numerico dois digitos -> 00", _
                  "Informe o mes dos repectivos nomes dos arquivos")

For sDia = 1 To 31

Filename = VBA.Format(sDia, "00") & VBA.Format(sMes, "00") & VBA.Format(Date, "yy") & _
                      ".xlsx"
                      
If VBA.Dir(sItem & "\" & Filename) <> "" Then

 Excel.Workbooks.Open Filename:=sItem & "\" & Filename, ReadOnly:=True
 
 LastRow = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, _
                                  SearchDirection:=xlPrevious).Row
 
 With ThisWorkbook.ActiveSheet
     ActiveSheet.Range("A1:D" & LastRow).Copy .Cells(.Rows.Count, "A"). _
     End(xlUp).Offset(1, 0)
     xlCopy = xlCopy + 1
     Excel.Workbooks(Filename).Close
 End With
 
End If

Next

If xlCopy > 0 Then MsgBox xlCopy & " Arquivos foram copiados do mês " & _
                          sMes, 64, " S u c e s s o "

Erro:

Excel.Application.ScreenUpdating = True

End Sub

 

[viclizz]

Bom dia Basole , 

 

tentei testar o codigo porém ele nao consegue encontrar as pastas 

 

 'Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = ' os arquivos estão em pastas que são nomeadas pelo mês. 

 

consegue me dar essa luz ? 

[Basole]

 @viclizz somente com imagens dos árquivos fica difícil te ajudar, dando um parecer.

 

Seria bom se pudesse anexar amostra dos arquivos que serão copiados, originais ou exemplos similares.