Excel Listar varias pastas e seus valores em outra.

[Kleitonkaza]

Olá!

Sou pouco leigo no assunto, gostaria de uma ajuda com VBA
Tenho um pasta (diretorio) fixa onde salvo diversas subpastas, cada um uma com um titulo numerado, onde dentro destas fica salvo um arquivo excel xlsm com dados de orçamento,

Já consegui uma macro onde eu listo o nome de todas as pasta existente neste diretorio e salvo em uma outra planilha especifica, porém estou tentando fazer a seguinte situação:

que a macro copie o valor da celula especifica de cada arquivo excel e salve nesta planilha especifica, as planilhas de orçamentos são iguais logo o valor sempre será na mesma celula, mudando somente o nome de cada planilha e cada pasta que ela se encontra,

 

em Resumo para melhor entendimento, de maneira manual eu tenho uma planilha de controle onde, eu vou nesta pasta que constam todas as subpastas de orçamentos, copio todos os nomes e colo nesta planilha de controle, após isto eu abro cada subpasta de orçamento xlsm e abro cada arquivo e copio o valor da celula H515 e colo nesta planilha de controle ao lado do respectivo nome...

 

poderiam me auxiliar nesta execução, por gentileza ?

 

att

 

Kleiton

 

 

[Basole]

@Kleitonkaza veja este exxemplo se consegue adaptar

 

Sub CopiarDadosVariasPlans()
Dim WS As Worksheet
Dim myfolder As String
Dim Str As String
Dim a As Single
Dim sht As Worksheet
  
Set WS = Sheets.Add
  
With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    myfolder = .SelectedItems(1) & "\"
End With
  
Value = Dir(myfolder)
Do Until Value = ""
    If Value = "." Or Value = ".." Then
    Else
        If VBA.Right(Value, 3) = "xls" Or VBA.Right(Value, 4) = "xlsx" Or VBA.Right(Value, 4) = "xlsm" Then
            On Error Resume Next
            Workbooks.Open Filename:=myfolder & Value, Password:="zzzzzzzzzzzz"
            If Err.Number > 0 Then
            Else
                On Error GoTo 0
                For Each sht In ActiveWorkbook.Worksheets
                    If sht.Range("A1") <> "" Then
                        Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
                        sht.Range("H515").Copy Destination:=WS.Range("H515")
                    End If
                Next sht
            End If
            Workbooks(Value).Close False
            On Error GoTo 0
        End If
    End If
    Value = Dir
Loop

End Sub

 

credito: shorturl.at/sESZ2

[Kleitonkaza]

Obrigado pela ajuda @Basole
Fiz alguns teste sem modificações na escrita, mas vou fazer outros aindas para verificar, pois percebi que ele abre, le e fecha todos os arquivos contidos na pasta que seleciono, gera uma aba nova na planilha que estou usando mas não registra os valores da celula H515 em lista nesta aba nova....ficando apenas uma aba nova vazia...

vou dar uma olhada com mais calma amanhã e ver o que ocorre novamente....assim também posto a planilha aqui...

 

De todo modo muito obrigado!