How to copy cells from many workbooks into one workbook

[agafon]

Hello.

I got hundreds of workbooks with exactly the same structure.
I want to copy from all of them the same cells and transfer them into one master workbook.
I want it go this way : from the first workbook A5, A6, A21, A22, A23, A73, A77 will be transferred into B3, C3, D3, E3, F3, G3, H3 in master workbook.
From the second workbook A5, A6, A21, A22, A23, A73, A77 will be transferred into B4, C4, D4 etc. in master workbook
From the third the same range into B5 , C5 etc. in master workbook

Thanks in advance for help

 

[Andrew Poulsom]

Welcome to MrExcel.

You seem to be writing to the same cells more than once there.

 

[agafon]

You're right. I 've just edited my post.

 

[GTO]

Is this all from the first sheet (index) or a particular named sheet or all sheets in the source wb's?

 

[agafon]

No, GTO. They aren't worksheets, they are workbooks.

 

[GTO]

In the source workbooks (where you are wanting to copy from), there are one or more worksheets. I was asking as to how we know which sheet(s) in the source workbooks to copy from.

 

[agafon]

I see. There is only one sheet in each workbook.

 

[GTO]

If all the workbooks are in the same folder as the "master", I think this would work. Please note that I used the default codename for the sheet in master.

Option Explicit
    
Sub exa()
Dim fsoFil          As Object
Dim wb              As Workbook
Dim rngLastCell     As Range
Dim lNextRow        As Long
Dim Path            As String
Dim aVnt(1 To 7)    As Variant
    
    Path$ = ThisWorkbook.Path & "\"
    
    Set rngLastCell = RangeFound(Range(Sheet1.Cells(3, "B"), Sheet1.Cells(Sheet1.Rows.Count, "H")))
    If Not rngLastCell Is Nothing Then
        lNextRow = rngLastCell.Row + 1
    Else
        lNextRow = 3
    End If
    
    For Each fsoFil In CreateObject("Scripting.FileSystemObject").GetFolder(Path).Files
        If Not fsoFil.Path = ThisWorkbook.FullName Then
            Set wb = Workbooks.Open(fsoFil.Path)
            With wb.Worksheets(1)
                aVnt(1) = .Range("A5").Value
                aVnt(2) = .Range("A6").Value
                aVnt(3) = .Range("A21").Value
                aVnt(4) = .Range("A22").Value
                aVnt(5) = .Range("A23").Value
                aVnt(6) = .Range("A73").Value
                aVnt(7) = .Range("A77").Value
            End With
            wb.Close False
            Range(Sheet1.Cells(lNextRow, "B"), Sheet1.Cells(lNextRow, "H")).Value = aVnt
            lNextRow = lNextRow + 1
        End If
    Next
End Sub
    
Function RangeFound(SearchRange As Range, _
                    Optional FindWhat As String = "*", _
                    Optional StartingAfter As Range, _
                    Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
                    Optional LookAtWholeOrPart As XlLookAt = xlPart, _
                    Optional SearchRowCol As XlSearchOrder = xlByRows, _
                    Optional SearchUpDn As XlSearchDirection = xlPrevious, _
                    Optional bMatchCase As Boolean = False) As Range
    
    If StartingAfter Is Nothing Then
        Set StartingAfter = SearchRange(1)
    End If
    
    Set RangeFound = SearchRange.Find(What:=FindWhat, _
                                      After:=StartingAfter, _
                                      LookIn:=LookAtTextOrFormula, _
                                      LookAt:=LookAtWholeOrPart, _
                                      SearchOrder:=SearchRowCol, _
                                      SearchDirection:=SearchUpDn, _
                                      MatchCase:=bMatchCase)
End Function

 

[agafon]

Thanks very much, GTO. I will try it and let you know if I didn't mess it.

 

[GTO]

You are most welcome. Please post back if anything goes awry or is unclear.