Macro to get a range from all selected worksheets on one worksheet

[Tpunt]

Hello Everybody,

My VBA skills aren't really good. As for now I've arguing with my laptop for 2 days and I am still not able to get it to work. So hopefully you can help me.

let me explain what I am trying to do.

I want te make a selection (by hand all files are in the same folder) and copy cells B2:Z2 from every worksheet in the selected workbooks to a new file where all these "B2:Z2" ranges have to be on one single worksheet. Below each other.

This is what i came up with in de last two days

Sub CombineWorkbooks()    Dim xlWkbk As String
    Dim xlWkshName As String
    Dim xlWksh As Object
    Dim xlWkshM As Object
    Dim FilesToOpen
    Dim x As Integer
    Dim xn As Long
    Dim n As Integer
    Dim i As Integer
    Dim sourceRange As Range
    Dim destrange As Range
    Dim a As Long
    Dim basebook As Workbook
    
    Set basebook = ThisWorkbook
    


  On Error GoTo ErrHandler
    Application.ScreenUpdating = False


    FilesToOpen = Application.GetOpenFilename _
                  (MultiSelect:=True, Title:="Files to Merge")


    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "No Files were selected"
        GoTo ExitHandler
    End If
    xn = 1
    x = 1
    While x <= UBound(FilesToOpen)


        Workbooks.Open Filename:=FilesToOpen(x)
        xlWkbk = ActiveWorkbook.Name
        n = 1
        For n = 1 To ActiveWorkbook.Worksheets.Count
        
        Set sourceRange = ActiveWorkbook.Worksheets(n).Range("b2:z2")
                    a = sourceRange.Rows.Count
                    With sourceRange
                        Set destrange = basebook.Worksheets(1).Cells(xn, 1). _
                                    Resize(.Rows.Count, .Columns.Count)
                    End With
                    destrange.Value = sourceRange.Value
              
              xn = xn + a
              Next n
              Workbooks(xlWkbk).Close False
        x = x + 1
        
    Wend


ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub


ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

I really hope you guys can help me.

 

[JLGWhiz]

Hi Tpunt, I did not test this, but I think it will do what you want. If you get an error, post back with the message and line that is high lighted.

Code:
Sub CombineWorkbooks()
Dim xlWkbk As String
Dim xlWkshName As String
Dim xlWksh As Object
Dim xlWkshM As Object
Dim FilesToOpen
Dim x As Integer
Dim xn As Long
Dim sh As Worksheet
Dim i As Integer
Dim sourceRange As Range
Dim destrange As Range
Dim a As Long
Dim basebook As Workbook
Set basebook = ThisWorkbook
On Error GoTo ErrHandler
Application.ScreenUpdating = False
FilesToOpen = Application.GetOpenFilename _
(MultiSelect:=True, Title:="Files to Merge")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If
x = 1
While x <= UBound(FilesToOpen)
xn = basebook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Workbooks.Open Filename:=FilesToOpen(x)
xlWkbk = ActiveWorkbook.Name
For Each sh In Workbooks(xlWkbk)
Set sourceRange = sh.Range("b2:z2")
With sourceRange
Set destrange = basebook.Worksheets(1).Cells(xn + 1, 1). _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
Next
Workbooks(xlWkbk).Close False
x = x + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
Code:

 

[Tpunt]

Thank you JLGWhiz for your time,

I get a run-time error'438': Object doesn't support this property or method error.

Sub CombineWorkbooks1()Dim xlWkbk As String
Dim xlWkshName As String
Dim xlWksh As Object
Dim xlWkshM As Object
Dim FilesToOpen
Dim x As Integer
Dim xn As Long
Dim sh As Worksheet
Dim i As Integer
Dim sourceRange As Range
Dim destrange As Range
Dim a As Long
Dim basebook As Workbook
Set basebook = ThisWorkbook
'On Error GoTo ErrHandler
Application.ScreenUpdating = False
FilesToOpen = Application.GetOpenFilename _
(MultiSelect:=True, Title:="Files to Merge")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If
x = 1
While x <= UBound(FilesToOpen)
xn = basebook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Workbooks.Open Filename:=FilesToOpen(x)
xlWkbk = ActiveWorkbook.Name
For Each sh In Workbooks(xlWkbk)
Set sourceRange = sh.Range("b2:z2")
With sourceRange
Set destrange = basebook.Worksheets(1).Cells(xn + 1, 1). _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
Next
Workbooks(xlWkbk).Close False
x = x + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
'ErrHandler:
'MsgBox Err.Description
Resume ExitHandler
End Sub

the error is in line

For Each sh In Workbooks(xlWkbk)

I hope you can help me again.

 

[JLGWhiz]

That line should be:

Code:
For Each sh In Workbooks(xlWkbk).Sheets
Code:

See if that fixes it.

 

[Tpunt]

thank you very much JLGWhiz,

After another couple of tweaks and including a progressbar (it has to go through 200-600 files all of them with at least 5 worksheets) i got it to work.

The final code for me is:

Sub get_Data_from_SPC()Dim xlWkbk As String
Dim xlWkshName As String
Dim xlWksh As Object
Dim xlWkshM As Object
Dim FilesToOpen
Dim x As Integer
Dim xn As Long
Dim sh As Worksheet
Dim i As Long
Dim sourceRange As Range
Dim destrange As Range
Dim a As Long
Dim basebook As Workbook
Set basebook = ThisWorkbook


On Error GoTo ErrHandler


    Application.ScreenUpdating = False


        FilesToOpen = Application.GetOpenFilename _
                    (MultiSelect:=True, Title:="Files to Merge")


        If TypeName(FilesToOpen) = "Boolean" Then
                MsgBox "No Files were selected"
                GoTo ExitHandler
        End If


    x = 1


    While x <= UBound(FilesToOpen)


        


    Workbooks.Open Filename:=FilesToOpen(x)
        xlWkbk = ActiveWorkbook.Name
i = 1
        For i = 1 To Workbooks(xlWkbk).Sheets.Count
        
                Set sourceRange = Workbooks(xlWkbk).Sheets(i).Range("b2:z2")
                With sourceRange
                        Set destrange = basebook.Worksheets(1).Cells(xn + 1, 1). _
                                        Resize(.Rows.Count, .Columns.Count)
                End With


                destrange.Value = sourceRange.Value
xn = basebook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
                Next i


        Workbooks(xlWkbk).Close False
        x = x + 1
        
        PctDone = x / UBound(FilesToOpen)
        
        With UserForm2
            .FrameProgress.Caption = Format(PctDone, "0%")
            .LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
        End With
        
        DoEvents
        
        
        
    Wend
Unload UserForm2


ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub

 

[JLGWhiz]

Glad you got it working and thanks for posting the results. That helps others who have similar problems.

Regards, JLG