Merge Multiple Ranges of Data

cowen49 · Jun 13th 2018

Hi,

I’m after some assistance creating the correct VBA to do the following:

-I have 14 workbooks all contained within the same folder.
-The folders path will be “C:\Users\cowen\Documents\Yield Tracker V2”
-Within these workbooks is a data entry sheet which is sheet fall but named, “DBEntry”
-The layout of these sheets and the headers are exactly the same for all 14 sites which each have 1 workbook.
I want to be able to copy across the data from the DB entry sheet, this will always be between column B and s however depending on the amount of data entered it may be 20 rows or it may be 200 rows. Once copied I was the information deposited into an Workbook called Yield Tracker V2 Master and within that sheet DB Entry.
I would like all the data to merge rather than each workbook over-right the previous one.

Any help is greatly appreciated Colin

Mumps · Jun 13th 2018

Copy/paste this macro into a regular module in your

[SIZE=13px]Yield Tracker V2 Master workbook and run it from there. The macro assumes that your source files all have an "xlsx" extension and that they are the only files in your folder.[/SIZE]

Code

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wsDest As Worksheet
    Set wsDest = ThisWorkbook.Sheets("DBEntry")
    Dim wkbSource As Workbook
    Dim LastRow As Long
    Const strPath As String = "C:\Users\cowen\Documents\Yield Tracker V2\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            LastRow = .Sheets("DBEntry").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets("DBEntry").Range("B1:S" & LastRow).Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Display More

cowen49 · Jun 13th 2018

Hi Mumps,

Thank you for the quick reply,

I've tried this and it gives a run time error 9 Subscript out of range.

The line of code highlighted is, Set wsDest = ThisWorkbook.Sheets("DBEntry")

Just another FYI the source files are macro enabled so am I correct in changing the extension in the VBA code to .xlsm.

Thanks

Colin

jolivanes · Jun 13th 2018

Colin
In Post #1 you mention "DBEntry" as well as "DB Entry" (with a space).
Make sure that the Sheet name in the code is the same as your actual Sheet name.

cowen49 · Jun 13th 2018

Hi Jolivanes,

Thanks, for this, I have an nasty habit of inconsistency which I had carried over the master sheet. I've rectified this and it's working which is amazing Thank You.

However a couple of bits I've noticed:

-I'm Testing it with 2 sheets currently and the last sheet that is opened and copied is the only data on the destination sheet in the master workbook.

-Also the data is bring dropped in Cell A3 which included the header row. How would I make it so only the entered data is copied across, this is located in cell B3 on the worksheets.

Thanks

Colin

cowen49 · Jun 13th 2018

Hi,

Further update on this, it turned out the cells aren't overwriting but rather it's copying all 40,000 rows over rather than just the rows which contain data.

Thanks

Colin

Mumps · Jun 13th 2018

Is it now working the way you want it? If not, please explain how it is not working.

cowen49 · Jun 13th 2018

It's copying over all the rows on the data inputting sheet regardless of if they have completed data in them. Also the data is being dropped in with headers, the headers are on row 2 the data begins row 3.

Mumps · Jun 13th 2018

It would be easier to help if you could post a copy of your

[SIZE=13px]Yield Tracker V2 Master workbook and a copy of at least one of your source workbooks. You can de-sensitize the data if necessary.[/SIZE]

cowen49 · Jun 14th 2018

Hi Mumps,
Sorry about the delay, I had to get the go ahead first. I've de-sensitized the data. I've included the data entry book which is store1 and the master Yield Tracker V2 Sheet where the Macro is located.

I couldn't upload due to file size so please try the below DropBox Link.

https://www.dropbox.com/sh/tr9…H5_JFlYWiQ7gXDL70Vta?dl=0

Thanks

Colin

Mumps · Jun 14th 2018

Try:

Code

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wsDest As Worksheet
    Set wsDest = ThisWorkbook.Sheets("DBEntry")
    Dim wkbSource As Workbook
    Dim LastRow As Long, LastRow2 As Long
    Const strPath As String = "C:\Users\cowen\Documents\Yield Tracker V2\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsm")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            LastRow = WorksheetFunction.CountA(.Sheets("DBEntry").Range("B:B"))
            LastRow2 = WorksheetFunction.CountA(wsDest.Range("B:B")) + 1
            .Sheets("DBEntry").Range("B3:S" & LastRow).Copy wsDest.Cells(LastRow2, 1)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Display More

cowen49 · Jun 14th 2018

Amazing, just 2 issues I can see.

The first is when there are two sheets it seems to cut off the last row of data on the second file copied across, the second is how would I get the starting depositing position to be B:2 instead of A:1

Great job BTW

Colin

Mumps · Jun 15th 2018

Can you post a copy of that second file where the last row is cut off?

cowen49 · Jun 19th 2018

Hi mumps,

Sorry I've been out of the business a few days.

I've managed to get the placement correct, the issue seems to be if the source data has a blank row between rows of data then it doesn't copy all of the data over.

See link below:

https://www.dropbox.com/sh/tr9…H5_JFlYWiQ7gXDL70Vta?dl=0

Thanks

Colin

Mumps · Jun 19th 2018

Is it necessary to have 40000 rows in the "Store" workbooks?

cowen49 · Jun 19th 2018

Hi,

No necessarily but I think across a quarter we will collect around 15,000 lines of data depending on how many blank rows it leaves.

Thanks

Mumps · Jun 19th 2018

Click here for your files. You will see 2 macros in Module1 of the Master. I was trying two different methods to see which would be faster. Unfortunately, they both seem to take about the same amount of time. You can try both and see what you observe. I have deleted about 25000 empty rows from each of the two "Store" files. They now have 15000 rows. This speeds things up a bit compared to the original files that had 40000 rows. The more empty rows you can delete from the source files, the faster the macro will run. Give them a try.

apo · Jun 20th 2018

Hi..

Here's another that works on your sample (although you MUST remove the text "End" that was in row 15000 (the black row) on each of you DBEntry sheets.. not sure why that was there.. and it makes it hard to find the last used row of data..

The idea below is to read each Workbook once, add data to Collection and build array, then dump array to sheet.. so as little sheet interactions as possible.

I haven't played with Collections much at all, but found Pikes thread on it valuable.. https://www.ozgrid.com/forum/f…excel-vba-collection-sort

It seems you can't dump a Collection straight to sheet( like you would an array)so that's why the extra step of building the array from the Collection is needed..

Code

Private Sub CommandButton1_Click()
    Dim myList As New Collection, myItem
    Dim x, xx, y, SelFold As String, i As Long, ii As Long, iii As Long, k As Long, kk As Long


    SelFold = "C:\Users\cowen\Documents\Yield Tracker V2"
    x = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & SelFold & "\*.xls*"" /s/b").stdout.readall, vbCrLf)
 
    Set myItem = New Collection
    
    For i = LBound(x) To UBound(x) - 1
    
        With GetObject(x(i))
            xx = .Sheets("DBEntry").Range("B3:S" & .Sheets("DBEntry").Range("B" & Rows.Count).End(xlUp).Row)
            For ii = LBound(xx) To UBound(xx)
                If xx(ii, 1) <> "" Then
                    For iii = LBound(xx, 2) To UBound(xx, 2)
                        
                        myItem.Add Item:=xx(ii, iii)
                    Next iii
                    myList.Add Item:=myItem
                End If
                Set myItem = New Collection
            Next ii
            .Close
        End With
        
    Next i
    
    ReDim y(1 To myList.Count, 1 To 18)
    For k = 1 To myList.Count
        For kk = 1 To 18
            y(k, kk) = myList(k).Item(kk)
        Next kk
    Next k
    Sheets("DBEntry").[B3].Resize(UBound(y), UBound(y, 2)) = y
    Set fldr = Nothing
End Sub

Display More

cowen49 · Jun 21st 2018

Hi Mumps,

I downloaded both Macro's and run them both, however both cause Excel to crash immediately, see screen shot linked below:

https://www.dropbox.com/s/wwnd…e5/Macro%20Crash.png?dl=0

APO late to the party but the solution works perfectly, I've removed the END row and run the macro a couple of times and it works very efficiently, Thank You.

Mumps · Jun 21st 2018

This version should work and is much faster. You don't have to remove the "END" row.

Code

Sub CopyRange()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim wsDest As Worksheet
    Set wsDest = ThisWorkbook.Sheets("DBEntry")
    Dim wkbSource As Workbook
    Dim LastRow As Long, LastRow2 As Long
    'Const strPath As String = "C:\Users\cowen\Documents\Yield Tracker V2\"
    Const strPath As String = "C:\Test2\"
    ChDir strPath
    strextension = Dir(strPath & "*.xlsm")
    Application.DisplayAlerts = False
        Do While strextension <> ""
            If ThisWorkbook.Name <> strextension Then
                Set wkbSource = Workbooks.Open(strPath & strextension)
                With wkbSource
                    LastRow = .Sheets("DBEntry").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    .Sheets("DBEntry").Rows(LastRow).EntireRow.Delete
                    LastRow = .Sheets("DBEntry").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
                    LastRow2 = WorksheetFunction.CountA(wsDest.Range("B:B")) + 3
                    .Sheets("DBEntry").Range("B3:S" & LastRow).Copy wsDest.Cells(LastRow2, 2)
                    If WorksheetFunction.CountBlank(wsDest.Range("B3:B" & wsDest.Range("B" & wsDest.Rows.Count).End(xlUp).Row)) <> 0 Then
                        wsDest.Range("B3:B" & LastRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                    End If
                    .Close savechanges:=False
                End With
            End If
            strextension = Dir
        Loop
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Display More

Merge Multiple Ranges of Data

Participate now!

Share