Extracting data from two sheets in external workbooks - 2nd sheet won't paste

**ids** · 12-06-2013, 11:27 AM

I have been extracting data from a number of workbooks and in this case I need B4:B34 from sheets 4 and 6 on external workbooks.
What I need is the filename in col A and the extracted data in column B, so 2 lots of 32 cells. First sheet would then occupy A1:B64. Next sheet would take A65:B128 and so on.
This code works fine but only extracts from sheet 4 on each file.
Can anyone see the flaw(S)? Thanks.

Sub MergeAllWorkbooks()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim sourceRange1 As Range, destrange1 As Range
    Dim rnum As Long, CalcMode As Long

    ' Change this to the path\folder location of your files.
    MyPath = "C:\temp1"


    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    ' If there are no Excel files in the folder, exit.
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    ' Fill the myFiles array with the list of Excel files
    ' in the search folder.
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop

    ' Set various application properties.
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    ' Set worksheet for information to be merged to.
    Set BaseWks = Worksheets(1)
    rnum = 2

    ' Loop through all files in the myFiles array.
    If FNum > 0 Then
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0

            If Not mybook Is Nothing Then
                On Error Resume Next

                ' Change this range to fit your own needs.
                With mybook.Worksheets(6)
                    Set sourceRange = .Range("b4:b34")
                With mybook.Worksheets(4)
                    Set sourceRange1 = .Range("b4:b34")
                End With
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    ' If source range uses all columns then
                    ' skip this file.
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "There are not enough rows in the target worksheet."
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        ' Copy the file name in column A.
                        With sourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = MyFiles(FNum)
                        End With

                        ' Set the destination range.
                        Set destrange = BaseWks.Range("B" & rnum)
                        Set destrange1 = BaseWks.Range("B" & rnum)
                        ' Copy the values from the source range
                        ' to the destination range.
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        With sourceRange1
                            Set destrange1 = destrange1. _
                                            Resize(.Rows.Count, .Columns.Count)
                        destrange1.Value = sourceRange1.Value
                        End With
                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If

        Next FNum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    ' Restore the application properties.
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

**HaHoBe** · 12-06-2013, 02:51 PM

Hi, ids,

First sheet would then occupy A1:B64. Next sheet would take A65:B128

In your code to assign the very same destiantion range to both ranges instead of setting the second after the paste or including the offset for the first range with

                        Set destrange = BaseWks.Range("B" & rnum)
                        Set destrange1 = BaseWks.Range("B" & rnum)

And if you copy just

destrange1.Value = sourceRange1.Value

I´m missing the part like

destrange.Value = sourceRange.Value

either before or after that. Again: make sure you´re not assigning the same ranges to the destination ranges.

Ciao,
Holger

**ids** · 12-10-2013, 12:00 PM

Thanks for coming back to me there.
I have changed the destination ranges as you suggest.

 ' Set the destination range.
                        Set destrange = BaseWks.Range("B" & rnum)
                        Set destrange1 = BaseWks.Range("B" & rnum + 32)

Also, adjusted the 2nd destination range.
This is good because I now get all the info that I need, but the filename only appears in the first 30 rows.
Having said that and seen the results, I am now think that it would be better to have rows that do not contain any data supressed. I think this means a rethink of all the code?

**ids** · 01-07-2014, 09:23 AM

Please ignore last post - back on track again.
Stepping through the program using F8, Filename 1 pastes to A2-A31 then sheet 4 data is pasted into B2-B31, then sheet 6 is pasted into B32-B61. Filename 2 pastes to A32-A61 and the next sheet 4 overwrites the previous data.
Need Filename 1 A2-A61, sheet 4 cells to B2-B31, sheet 6 cells to B32-B61, then
Filename 2 A62-A121, sheet 4 cells to B62-B91, sheet 6 cells to B92-B121 etc., etc.
Cannot see how to increase the offset in column A with there being a knock on effect.
Can anyone see how this could be modified?

Current code:

Sub MergeAllWorkbooks()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim sourceRange1 As Range, destrange1 As Range
    Dim rnum As Long, CalcMode As Long

    ' Change this to the path\folder location of your files.
    MyPath = "C:\temp1"


    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    ' If there are no Excel files in the folder, exit.
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    ' Fill the myFiles array with the list of Excel files
    ' in the search folder.
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop

    ' Set various application properties.
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    ' Set worksheet for information to be merged to.
    Set BaseWks = Worksheets(1)
    rnum = 2

    ' Loop through all files in the myFiles array.
    If FNum > 0 Then
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0

            If Not mybook Is Nothing Then
                On Error Resume Next

                ' Change this range to fit your own needs.
                With mybook.Worksheets(6)
                    Set sourceRange = .Range("b5:b34")
                With mybook.Worksheets(4)
                    Set sourceRange1 = .Range("b5:b34")
                End With
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    ' If source range uses all columns then
                    ' skip this file.
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "There are not enough rows in the target worksheet."
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        ' Copy the file name in column A.
                        With sourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = MyFiles(FNum)
                        End With

                        ' Set the destination range.
                        Set destrange = BaseWks.Range("B" & rnum)
                        Set destrange1 = BaseWks.Range("B" & rnum + 30)
                        ' Copy the values from the source range
                        ' to the destination range. Overwrite is here
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        destrange.Value = sourceRange.Value
                        End With
                        With sourceRange1
                            Set destrange1 = destrange1. _
                                            Resize(.Rows.Count, .Columns.Count)
                        destrange1.Value = sourceRange1.Value
                        End With
                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If

        Next FNum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    ' Restore the application properties.
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

**HaHoBe** · 01-07-2014, 02:05 PM

Hi, ids,

                        ' Set the destination range.
                        Set destrange = BaseWks.Range("B" & rnum)
                        Set destrange1 = BaseWks.Range("B" & rnum + 30)

are the least of the lines which would need to be altered (no sheet6 to be copied when I glimpsed through the code).

Ciao,
Holger

**HaHoBe** · 01-08-2014, 12:50 AM

Hi, ids,

regarding different Columns you could use code like

                        ' Set the destination range.
                        Set destrange = BaseWks.Cells(rnum, BaseWks.Cells(2, Columns.Count).End(xlToLeft).Column + 1)
                        Set destrange1 = BaseWks.Cells(rnum + 30, BaseWks.Cells(2, Columns.Count).End(xlToLeft).Column + 1)

Regarding the rows where to copy you should comment out

                        rnum = rnum + SourceRcoun

in order not to go down the rows.

Ciao,
Holger

**ids** · 01-08-2014, 05:59 AM

Originally Posted by HaHoBe

Hi, ids,

                        ' Set the destination range.
                        Set destrange = BaseWks.Range("B" & rnum)
                        Set destrange1 = BaseWks.Range("B" & rnum + 30)

are the least of the lines which would need to be altered (no sheet6 to be copied when I glimpsed through the code).

Ciao,
Holger

Thanks Holger.
The problem I think is that I am trying to use 1 variable (sourcerange) to do two different things
Here for pasting filename:

' Copy the file name in column A.
                        With sourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = MyFiles(FNum)
                        End With

and here for pasting sheet 4 & sheet 6

' Copy the values from the source range
                        ' to the destination range. Overwrite is here
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        destrange.Value = sourceRange.Value
                        End With
                        With sourceRange1
                            Set destrange1 = destrange1. _
                                            Resize(.Rows.Count, .Columns.Count)
                        destrange1.Value = sourceRange1.Value
                        End With

The sheet 6 paste does occur here

With sourceRange1
                            Set destrange1 = destrange1. _
                                            Resize(.Rows.Count, .Columns.Count)
                        destrange1.Value = sourceRange1.Value

**HaHoBe** · 01-09-2014, 01:03 AM

Hi, ids,

The problem I think is that I am trying to use 1 variable (sourcerange) to do two different things

To be honest: I think you don´t really understand what the code is doing and maybe choose it because you believe it to be fitting for your problem but the code may be simplified due to your requests. Maybe it´s a good idea to put the cursor isnoide the procedure and use F8 to single step through the code in order to view what the code is supposed to do.

The problem about the filename is that you either have to do it every other column in order to get the proper name for each set of data. Or you put it above the data (like it is in my version). And I don´t believe it to be very efficient to create an array with the file names and only after that get on opening the files and work on them.

Sub MergeAllWorkbooks()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim sourceRange1 As Range, destrange1 As Range
    Dim rnum As Long, CalcMode As Long
    Dim lngCol As Long

    ' Change this to the path\folder location of your files.
    MyPath = "C:\temp1"

    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    ' If there are no Excel files in the folder, exit.
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    ' Fill the myFiles array with the list of Excel files
    ' in the search folder.
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop

    ' Set various application properties.
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    ' Set worksheet for information to be merged to.
    Set BaseWks = Worksheets(1)
    rnum = 2

    ' Loop through all files in the myFiles array.
    If FNum > 0 Then
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0

            If Not mybook Is Nothing Then
                On Error Resume Next

                ' Change this range to fit your own needs.
                Set sourceRange = mybook.Worksheets(6).Range("b5:b34")
                Set sourceRange1 = mybook.Worksheets(4).Range("b5:b34")

                If Not sourceRange Is Nothing Then

                        ' Copy the file name in column A.
                        lngCol = BaseWks.Cells(1, Columns.Count).End(xlToLeft).Column + 1
                        If BaseWks.Cells(1, 1).Value = "" Then
                          lngCol = 1
                        End If
                        BaseWks.Cells(rnum, lngCol).Value = MyFiles(FNum)

                        ' Set the destination range.
                        With BaseWks
                          Set destrange = .Cells(rnum, lngCol).Resize(30, 1)
                          Set destrange1 = .Cells(rnum + 30, lngCol).Resize(30, 1)
                        End With
                        ' Copy the values from the source range
                        ' to the destination range. Overwrite is here
                        destrange.Value = sourceRange.Value
                        destrange1.Value = sourceRange1.Value
'                    End If
                End If
                mybook.Close savechanges:=False
            End If

        Next FNum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    ' Restore the application properties.
    With Application
        .Calculation = CalcMode
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Ciao,
Holger

**ids** · 01-09-2014, 06:36 AM

Hi Holger, thanks for your continued assistance. I think your assumptions are quite correct

I am stepping through your new code with F8 and the first filename is written into A2. This is then overwritten by the sheet 6 data. Sheet 4 data is then written into A32.
Then the 2nd filename is written into A2, overwriting the first cell of sheet 6 data. Then sheet 4(2nd file) data overwrites the sheet 4 (1st file) data. This cycle is ongoing with further files.
Getting close but all data is being overwritten onto the same footprint at A2 and A32 start locations.

**HaHoBe** · 01-09-2014, 12:34 PM

Hi, ids,

you would need to correct the number where to start (I used 2 there - it should have been row 1 instead). So the data should get aligned under teh filename .

Ciao,
Holger

**ids** · 01-13-2014, 05:51 AM

OK thanks, I am getting data in adjacent columns for each external sheet now.
For my application, I need to reformat these sections vertically into the first two columns, "filename" & "Data" respectively.

**Izandol** · 01-17-2014, 11:48 AM

You may try:

Sub MergeAllWorkbooks()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim aSheets, vSheet
    
    aSheets = Array(4, 6)

    ' Change this to the path\folder location of your files.
    MyPath = "C:\temp1"

    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    ' If there are no Excel files in the folder, exit.
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    ' Fill the myFiles array with the list of Excel files
    ' in the search folder.
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop

    ' Set various application properties.
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    ' Set worksheet for information to be merged to.
    Set BaseWks = Worksheets(1)
    rnum = 2

    ' Loop through all files in the myFiles array.
    If FNum > 0 Then
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0

            If Not mybook Is Nothing Then
                On Error Resume Next

                ' Change this range to fit your own needs.
                For Each vSheet In aSheets
                    With mybook.Worksheets(vSheet)
                        Set sourceRange = .Range("b4:b34")
                    End With
    
                    If Err.Number > 0 Then
                        Err.Clear
                        Set sourceRange = Nothing
                    Else
                        ' If source range uses all columns then
                        ' skip this file.
                        If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                            Set sourceRange = Nothing
                        End If
                    End If
                    On Error GoTo 0
    
                    If Not sourceRange Is Nothing Then
    
                        SourceRcount = sourceRange.Rows.Count
    
                        If rnum + SourceRcount >= BaseWks.Rows.Count Then
                            MsgBox "There are not enough rows in the target worksheet."
                            BaseWks.Columns.AutoFit
                            mybook.Close savechanges:=False
                            GoTo ExitTheSub
                        Else
    
                            With sourceRange
                                ' Copy the file name in column A.
                                BaseWks.Cells(rnum, "A"). _
                                        Resize(.Rows.Count).Value = MyFiles(FNum)
                                ' copy data.
                                BaseWks.Range("B" & rnum).Resize(.Rows.Count, .Columns.Count).Value = .Value
                            End With
                            rnum = rnum + SourceRcount
                        End If
                    End If
                Next vSheet
                mybook.Close savechanges:=False
            End If

        Next FNum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    ' Restore the application properties.
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

**ids** · 01-17-2014, 12:06 PM

Hi Izandol, I will try this now. Thanks

**ids** · 01-17-2014, 12:14 PM

Perfect! Works exactly as I need - thanks Izandol

**Izandol** · 01-17-2014, 12:23 PM

You are welcome.

Extracting data from two sheets in external workbooks - 2nd sheet won't paste

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Extracting data from two sheets in external workbooks - 2nd sheet won't paste

Re: Extracting data from two sheets in external workbooks - 2nd sheet won't paste

Re: Extracting data from two sheets in external workbooks - 2nd sheet won't paste

Re: Extracting data from two sheets in external workbooks - 2nd sheet won't paste

Re: Extracting data from two sheets in external workbooks - 2nd sheet won't paste

Re: Extracting data from two sheets in external workbooks - 2nd sheet won't paste

Re: Extracting data from two sheets in external workbooks - 2nd sheet won't paste

Re: Extracting data from two sheets in external workbooks - 2nd sheet won't paste

Re: Extracting data from two sheets in external workbooks - 2nd sheet won't paste

Re: Extracting data from two sheets in external workbooks - 2nd sheet won't paste

Re: Extracting data from two sheets in external workbooks - 2nd sheet won't paste

Re: Extracting data from two sheets in external workbooks - 2nd sheet won't paste

Re: Extracting data from two sheets in external workbooks - 2nd sheet won't paste

Re: Extracting data from two sheets in external workbooks - 2nd sheet won't paste

Re: Extracting data from two sheets in external workbooks - 2nd sheet won't paste

Thread Information

Users Browsing this Thread

Similar Threads

Extracting data from multiple workbooks & multiple sheets into one summary workbook/sheet

Extracting and combining data from specific sheet from multiple workbooks

Copy Paste Data across Workbooks with multiple sheets & Referencing.

[SOLVED] extracting data from master sheet into sub sheets and automatic updating.

Extracting data in the same cells across multiple sheets to a summary sheet

Bookmarks

Bookmarks

Posting Permissions