Bom dia!!

Eu acho que você se esqueceu do anexo.

Att

Tem razão

FALHANOSTRA ... rs

A rotina anexa, faz o que descreveu, porem deve ser adaptada a sua real necessidade

Sub AbreArquivo()
Dim OldName As String, NewName As String, cSheet As String
Dim sDir As String, sPath As String, Msg As String
Dim rw As Long, i As Long
'Guarda o nome do Arquivo ativo
OldName = ThisWorkbook.Name
'Acha o numero da ultima coluna com valores (da linha 1)
rw = Cells(1, Cells.Columns.Count).End(xlToLeft).Column
'Guarda o nome da planilha ativa
cSheet = ActiveSheet.Name
'Determina o caminho a ser utilizado (neste caso mesmo diretorio deste arquivo
sPath = ThisWorkbook.Path

'Acrescenta, se necessario a barra na string do caminho
If Right(sPath, 1) <> "" Then
    sPath = sPath & ""
    Else
    sPath = sPath
End If
'Altera, temporariamente, o diretorio de trabaho, para o determinado na string.
ChDir sPath
sDir = Dir("*.xls?")
'Executa enquanto houver arquivo xls no diretorio
Do While sDir <> ""
    If sDir <> OldName Or sdr <> "" Then
        Application.DisplayAlerts = False
        Application.ScreenUpdating = False
        Workbooks.Open Filename:=sDir, UpdateLinks:=3
        rw = rw + 1
            Workbooks(OldName).Sheets("BD").Cells(1, rw) = Workbooks(sDir).Sheets("Síntese").Cells(33, 3).Value
            Workbooks(OldName).Sheets("BD").Cells(2, rw) = Workbooks(sDir).Sheets("Síntese").Cells(34, 3).Value
            Workbooks(OldName).Sheets("BD").Cells(3, rw) = Workbooks(sDir).Sheets("Síntese").Cells(35, 3).Value
            Workbooks(OldName).Sheets("BD").Cells(4, rw) = Workbooks(sDir).Sheets("Síntese").Cells(36, 3).Value
            Workbooks(OldName).Sheets("BD").Cells(5, rw) = Workbooks(sDir).Sheets("Síntese").Cells(37, 3).Value
            Workbooks(OldName).Sheets("BD").Cells(6, rw) = Workbooks(sDir).Sheets("Síntese").Cells(38, 3).Value
            Workbooks(OldName).Sheets("BD").Cells(7, rw) = Workbooks(sDir).Sheets("Síntese").Cells(36, 7).Value
            Workbooks(OldName).Sheets("BD").Cells(8, rw) = Workbooks(sDir).Sheets("Síntese").Cells(36, 10).Value
            Workbooks(OldName).Sheets("BD").Cells(9, rw) = Workbooks(sDir).Sheets("Síntese").Cells(38, 13).Value
            Workbooks(OldName).Sheets("BD").Cells(10, rw) = Workbooks(sDir).Sheets("Síntese").Cells(38, 15).Value
            Workbooks(OldName).Sheets("BD").Cells(11, rw) = Workbooks(sDir).Sheets("Síntese").Cells(38, 18).Value
            Workbooks(OldName).Sheets("BD").Cells(12, rw) = Workbooks(sDir).Sheets("Síntese").Cells(34, 15).Value
            Workbooks(OldName).Sheets("BD").Cells(13, rw) = Workbooks(sDir).Sheets("Síntese").Cells(35, 15).Value
            Workbooks(OldName).Sheets("BD").Cells(14, rw) = Workbooks(sDir).Sheets("Síntese").Cells(36, 15).Value
            Workbooks(OldName).Sheets("BD").Cells(15, rw) = Workbooks(sDir).Sheets("Síntese").Cells(41, 3).Value
            Workbooks(OldName).Sheets("BD").Cells(16, rw) = Workbooks(sDir).Sheets("Síntese").Cells(42, 3).Value
            Workbooks(OldName).Sheets("BD").Cells(17, rw) = Workbooks(sDir).Sheets("Síntese").Cells(43, 3).Value
            Workbooks(OldName).Sheets("BD").Cells(18, rw) = Workbooks(sDir).Sheets("Síntese").Cells(41, 10).Value
            Workbooks(OldName).Sheets("BD").Cells(19, rw) = Workbooks(sDir).Sheets("Síntese").Cells(43, 13).Value
            Workbooks(OldName).Sheets("BD").Cells(20, rw) = Workbooks(sDir).Sheets("Síntese").Cells(43, 15).Value
            Workbooks(OldName).Sheets("BD").Cells(21, rw) = Workbooks(sDir).Sheets("Síntese").Cells(43, 18).Value
            Workbooks(OldName).Sheets("BD").Cells(22, rw) = Workbooks(sDir).Sheets("Síntese").Cells(44, 6).Value
            Workbooks(OldName).Sheets("BD").Cells(23, rw) = Workbooks(sDir).Sheets("Síntese").Cells(30, 4).Value
            Workbooks(OldName).Sheets("BD").Cells(24, rw) = Workbooks(sDir).Sheets("Síntese").Cells(44, 15).Value
            Workbooks(OldName).Sheets("BD").Cells(25, rw) = Workbooks(sDir).Sheets("Síntese").Cells(47, 4).Value
            Workbooks(OldName).Sheets("BD").Cells(26, rw) = Workbooks(sDir).Sheets("Síntese").Cells(47, 7).Value
            Workbooks(OldName).Sheets("BD").Cells(27, rw) = Workbooks(sDir).Sheets("Síntese").Cells(69, 1).Value
            Workbooks(OldName).Sheets("BD").Cells(29, rw) = Workbooks(sDir).Sheets("Síntese").Cells(53, 2).Value
            Workbooks(OldName).Sheets("BD").Cells(30, rw) = Workbooks(sDir).Sheets("Síntese").Cells(54, 2).Value
            Workbooks(OldName).Sheets("BD").Cells(31, rw) = Workbooks(sDir).Sheets("Síntese").Cells(55, 2).Value
            Workbooks(OldName).Sheets("BD").Cells(32, rw) = Workbooks(sDir).Sheets("Síntese").Cells(56, 2).Value
            Workbooks(OldName).Sheets("BD").Cells(33, rw) = Workbooks(sDir).Sheets("Síntese").Cells(57, 2).Value
            Workbooks(OldName).Sheets("BD").Cells(34, rw) = Workbooks(sDir).Sheets("Síntese").Cells(58, 2).Value
            Workbooks(OldName).Sheets("BD").Cells(35, rw) = Workbooks(sDir).Sheets("Síntese").Cells(59, 2).Value
            Workbooks(OldName).Sheets("BD").Cells(36, rw) = Workbooks(sDir).Sheets("Síntese").Cells(60, 2).Value
            Workbooks(OldName).Sheets("BD").Cells(37, rw) = Workbooks(sDir).Sheets("Síntese").Cells(61, 2).Value
            Workbooks(OldName).Sheets("BD").Cells(38, rw) = Workbooks(sDir).Sheets("Síntese").Cells(62, 2).Value
            Workbooks(OldName).Sheets("BD").Cells(39, rw) = Workbooks(sDir).Sheets("Síntese").Cells(63, 2).Value
            Workbooks(OldName).Sheets("BD").Cells(40, rw) = Workbooks(sDir).Sheets("Síntese").Cells(64, 2).Value
            Workbooks(OldName).Sheets("BD").Cells(41, rw) = Workbooks(sDir).Sheets("Síntese").Cells(65, 2).Value
            Workbooks(OldName).Sheets("BD").Cells(42, rw) = Workbooks(sDir).Sheets("Síntese").Cells(66, 2).Value
            Workbooks(OldName).Sheets("BD").Cells(43, rw) = Workbooks(sDir).Sheets("Síntese").Cells(67, 2).Value
            Workbooks(OldName).Sheets("BD").Cells(44, rw) = Workbooks(sDir).Sheets("Síntese").Cells(68, 2).Value
                
        Workbooks(sDir).Close SaveChanges:=False
        sDir = Dir
    Else
        Exit Sub
    End If
Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Opa Reinaldo obrigado pela ajuda vou testando.

[]s

Pessoal,

Vejam só!

Esta rotina atendeu um pouco melhor estou enroscando no meio quando quero trazer os dados da celula B1 da planilha Principal e de B1:B4 da planilha dados

Podem me ajudar com a adaptação?

Option Explicit

Sub Consolidate()
'Adaptation  VH
'Author:     Jerry Beaucaire
'Date:       4/29/2011
'Summary:    Merge files in a specific folder into one master sheet (stacked)
'            Moves imported files into another folder

Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet

'Setup
    Application.ScreenUpdating = False  'speed up macro execution
    Application.EnableEvents = False    'turn off other macros for now
    Application.DisplayAlerts = False   'turn off system messages for now
    
    Set wsMaster = ThisWorkbook.Sheets("Master")    'sheet report is built into

With wsMaster
    If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
        .UsedRange.Offset(1).EntireRow.Clear
        NR = 2
    Else
        NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1    'appends data to existing data
    End If

'Path and filename (edit this section to suit)
    fPath = "C:Teste"            'remember final  in this string
    fPathDone = fPath & "Consolidado"     'remember final  in this string
    On Error Resume Next
        MkDir fPathDone                 'creates the completed folder if missing
    On Error GoTo 0
    fName = Dir(fPath & "*.xl*")        'listing of desired files, edit filter as desired

'Import a sheet from found files
    Do While Len(fName) > 0
        If fName <> ThisWorkbook.Name Then              'don't reopen this file accidentally
            Set wbData = Workbooks.Open(fPath & fName)  'Open file



        'This is the section to customize, replace with your own action code as needed
            LR = Range("A" & Rows.Count).End(xlUp).Row  'Find last row
            Range("A1:A" & LR).EntireRow.Copy .Range("A" & NR)
            wbData.Close False                                'close file
            NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1  'Next row
        End If
        fName = Dir                                       'ready next filename
    Loop
End With



ErrorExit:    'Cleanup
    ActiveSheet.Columns.AutoFit
    Application.DisplayAlerts = True         'turn system alerts back on
    Application.EnableEvents = True          'turn other macros back on
    Application.ScreenUpdating = True        'refreshes the screen
End Sub

Pessoal,

Ele começou a ler certo porém dá
Run-Time Error '-2147221080 (800401a8)':
Erro de Automação:

Olhem só o erro ocorre dentro do segundo While, por favor podem me auxiliar?

Sub Consolidate()
'Adaptation  VH
'Author:     Jerry Beaucaire
'Date:       4/29/2011
'Summary:    Merge files in a specific folder into one master sheet (stacked)
'            Moves imported files into another folder

Dim fName As String, fPath As String, fPathDone As String, Dept As String
Dim LR As Long, NR As Long, FSline As Long, FScol As Long, i As Long, OSline As Long, OScol As Long
Dim wbData As Workbook, wsMaster As Worksheet
Dim Count As Integer

Count = 0

'Setup
    Application.ScreenUpdating = False  'speed up macro execution
    Application.EnableEvents = False    'turn off other macros for now
    Application.DisplayAlerts = False   'turn off system messages for now
    
    Set wsMaster = ThisWorkbook.Sheets("Master")    'sheet report is built into

With wsMaster
    If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
        .UsedRange.Offset(1).EntireRow.Clear
        NR = 2
    Else
        NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1    'appends data to existing data
    End If

'Path and filename (edit this section to suit)
    fPath = "C:Teste"            'remember final  in this string
    fPathDone = fPath & "Consolidado"     'remember final  in this string
    On Error Resume Next
        MkDir fPathDone                 'creates the completed folder if missing
    On Error GoTo 0
    fName = Dir(fPath & "*.xl*")        'listing of desired files, edit filter as desired
    
    
OSline = 1

'Import a sheet from found files
    Do While Len(fName) > 0
        If fName <> ThisWorkbook.Name Then              'don't reopen this file accidentally
            Set wbData = Workbooks.Open(fPath & fName)  'Open file

        FSline = 2
        
        'This is the section to customize, replace with your own action code as needed
            Dept = wbData.Worksheets("Principal").Range("B1")
            
            FScol = 1
            OScol = 2
            
            .Cells(FSline, FScol).Value = Dept
            FScol = FScol + 1
            
            'Loop onde ocorre o Erro!
            While FScol <= 4
            'Debug.Print "FScol = " & FScol
            wsMaster.Cells(FSline, FScol).Value = wbData.Worksheets("dados").Cells(OSline, OScol).Value
            OSline = OSline + 1
            FScol = FScol + 1
            
            wbData.Close False                                'close file
                                      
            Wend
        
        OSline = OSline + 1
        
        End If
        Debug.Print fName
        fName = Dir()           'ready next filename
    Count = Count + 1
    
'   Debug.Print "wbData = " & wbData
    Debug.Print "Dept = " & Dept
    Debug.Print "LR = " & LR
    Debug.Print "NR = " & NR
    
    
    Debug.Print "Count = " & Count
    Loop
End With



ErrorExit:    'Cleanup
    ActiveSheet.Columns.AutoFit
    Application.DisplayAlerts = True         'turn system alerts back on
    Application.EnableEvents = True          'turn other macros back on
    Application.ScreenUpdating = True        'refreshes the screen


End Sub

Provavelmente é por fechar o arquivo ( wbData.Close False 'close file), após a primeira passada. Coloque essa instrução depois de wend e teste

Opa Reinaldo valeu pela dica vou testar e dou um feedback!

Reinaldo e pessoal,

Tá quase! ... kkkkkk

Eu mudei um pouco o Loop e ele traz os valores certos a partir da segunda linha, conseguem me ajudar pra trazer o valor da célula (1, 2)

Olhem só a parte:

'This is the section to customize, replace with your own action code as needed
                Dept = wbData.Worksheets("Principal").Range("B1")
               
                FScol = 1
                OScol = 2
                OSline = 1
               
                .Cells(FSline, 1).Value = Dept
                
                'Loop onde ocorre o Erro!
                While FScol < 5
                FScol = FScol + 1
                
                wbData.Worksheets("dados").Cells(OSline + 1, OScol).Copy Destination:=wsMaster.Cells(FSline, FScol + 1)
                OSline = OSline + 1

                Wend
                
                wbData.Close False                                'close file
                                         
            'OSline = OSline + 1
           
            End If
            
            fName = Dir()           'ready next filename
        Count = Count + 1
        FSline = FSline + 1
        
        Loop

Olha o resultado parcial:

|Departamento |Nome |Sobrenome |Idade |Sexo
|Financeiro | |Souza |33 |Feminino
|Marketing | |Durão |28 |Masculino

A coluna Nome está ficando vazia, é como se não estive trazendo o valor,

Por favor me ajudem!

Vlw,

Não sou fã dessa maneira de leitura, tambem não entendi claramente o que deseja,mas vamos tentar:
voce inicia o valor de FScol=1 então depois ao iniciar o while.. determina FScol=FScol+1 ou seja 2, então irá comecar a "gravar" os dados na coluna 3 de wsMaster. Porque ?
Pode disponibilizar o codigo inteiro (com está atualmente) e os exem,plos iniciais, porem com 2 ou 3 exemplos de como estarão nas planilhas a serem lidas e como espera que fiquem na consolidado?

Po legal qual maneira de leitura recomendaria?

Não o copy/destination

mas o Cell.Value = Cell.Value?

É aprendizado também! Pode recomendar!

O código completo está abaixo:

 Option Explicit
    
    Sub Consolidate()
    'Adaptation  VH
    'Author:     Jerry Beaucaire
    'Date:       4/29/2011
    'Summary:    Merge files in a specific folder into one master sheet (stacked)
    '            Moves imported files into another folder

    Dim fName As String, fPath As String, fPathDone As String, Dept As String
    Dim LR As Long, NR As Long, FSline As Long, FScol As Long, i As Long, OSline As Long, OScol As Long
    Dim wbData As Workbook, wsMaster As Worksheet
    Dim Count As Integer

    Count = 0

    'Setup
        Application.ScreenUpdating = False  'speed up macro execution
        Application.EnableEvents = False    'turn off other macros for now
        Application.DisplayAlerts = False   'turn off system messages for now
       
        Set wsMaster = ThisWorkbook.Sheets("Master")    'sheet report is built into

    With wsMaster
        If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
            .UsedRange.Offset(1).EntireRow.Clear
            NR = 2
        Else
            NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1    'appends data to existing data
        End If

    'Path and filename (edit this section to suit)
        fPath = "C:Teste"            'remember final  in this string
        fPathDone = fPath & "Consolidado"     'remember final  in this string
        On Error Resume Next
            MkDir fPathDone                 'creates the completed folder if missing
        On Error GoTo 0
        fName = Dir(fPath & "*.xl*")        'listing of desired files, edit filter as desired
       
    OSline = 1
    FSline = 2

    'Import a sheet from found files
        Do While Len(fName) > 0
            If fName <> ThisWorkbook.Name Then              'don't reopen this file accidentally
                Set wbData = Workbooks.Open(fPath & fName)  'Open file
           
            'This is the section to customize, replace with your own action code as needed
                Dept = wbData.Worksheets("Principal").Range("B1")
               
                FScol = 1
                OScol = 2
                OSline = 1
               
                .Cells(FSline, 1).Value = Dept
                
                'Loop onde ocorre o Erro!
                While FScol < 5
                FScol = FScol + 1
                
                wbData.Worksheets("dados").Cells(OSline + 1, OScol).Copy Destination:=wsMaster.Cells(FSline, FScol + 1)
                OSline = OSline + 1

                Wend
                
                wbData.Close False                                'close file
                                                   
            End If
            
            fName = Dir()           'ready next filename
        Count = Count + 1
        FSline = FSline + 1
        
        Loop
    
    End With

ErrorExit:        'Cleanup
        ActiveSheet.Columns.AutoFit
        Application.DisplayAlerts = True         'turn system alerts back on
        Application.EnableEvents = True          'turn other macros back on
        Application.ScreenUpdating = True        'refreshes the screen

    End Sub

Achei o erro estava na parte:

wbData.Worksheets("dados").Cells(OSline + 1, OScol).Copy Destination:=wsMaster.Cells(FSline, FScol)

Substitui para:

wbData.Worksheets("dados").Cells(OSline, OScol).Copy Destination:=wsMaster.Cells(FSline, FScol)
OSline = OSline + 1

Mas continuo curioso sobre o método que utilizaria para fazer leitura!

[]s

Estava comentando algumas parte do codigo, para confirmar se era o realmente esperado, mas já que achou a diferença Ok.
Porem segue comentado talvez retire (ou acrescente) alguma duvida. Retirei também do código trechos e declarações de variáveis não utilizados.

Option Explicit
    Sub Consolidate()
    'Adaptation  VH
    'Author:     Jerry Beaucaire
    'Date:       4/29/2011
    'Summary:    Merge files in a specific folder into one master sheet (stacked)
    '            Moves imported files into another folder

    Dim fName As String, fPath As String, Dept As String
    Dim NR As Long, FSline As Long, FScol As Long, OSline As Long, OScol As Long
    Dim wbData As Workbook, wsMaster As Worksheet
    
    'Setup
    '    Application.ScreenUpdating = False  'speed up macro execution
    '    Application.EnableEvents = False    'turn off other macros for now
    '    Application.DisplayAlerts = False   'turn off system messages for now
       
        Set wsMaster = ThisWorkbook.Sheets("Master")    'sheet report is built into

    With wsMaster

    'Path and filename (edit this section to suit)
        fPath = "C:Teste"             'remember final  in this string
        fName = Dir(fPath & "*.xl*")    'listing of desired files, edit filter as desired
       
    OSline = 1
    FSline = 2

    'Import a sheet from found files
        Do While Len(fName) > 0                             'Executa enquanto tiver nome de arquivo achado
            If fName <> ThisWorkbook.Name Then              'don't reopen this file accidentally
                Set wbData = Workbooks.Open(fPath & fName)  'Open file
           
            'This is the section to customize, replace with your own action code as needed
                Dept = wbData.Worksheets("Principal").Range("B1")
                .Cells(FSline, 1).Value = Dept 'Celula A2 (na primeira "passada") da planilha Master = Celula B1 do arquivo aberto
               
                FScol = 1
                OScol = 2
                OSline = 1
               
                'Loop onde ocorre o Erro!
                While FScol < 5     'Executa da coluna 1 até coluna 4
                FScol = FScol + 1   'Inicia na coluna 2 (na primeira passada)
                'Copia valores da celula B1 (na primeira passada) para celula C2 da planilha master (na primeira passada)
                'Ja na segunda "passada" copia de B2 para celula D2 da master
                wbData.Worksheets("dados").Cells(OSline, OScol).Copy Destination:=wsMaster.Cells(FSline, FScol + 1)
                'Aqui determina Osline =2 após primeira passada.
                OSline = OSline + 1

                Wend
                
                wbData.Close False                                'close file
                                                   
            End If
            
            fName = Dir()           'ready next filename
        FSline = FSline + 1
        
        Loop
    
    End With

    '    ActiveSheet.Columns.AutoFit
    '    Application.DisplayAlerts = True         'turn system alerts back on
    '    Application.EnableEvents = True          'turn other macros back on
    '    Application.ScreenUpdating = True        'refreshes the screen

    End Sub

Existem, em varias atividades, as preferencias pessoais; eu na maioria das vezes prefiro utilizar conforme o código que dispus inicialmente. Tipo ws.cell.value=wb.cell.value