Transfer data from multiple workbooks ending at first blank row.

inkslinger12345

New Member
Joined
Jun 7, 2014
Messages
14
Let me see if I can explain this correctly. The company I now work for has all orders saved as individual excel worksheets. I have been working on a module that will, when run, go to the folder where all my files are located and transfer rows of data from the daily worksheets to a single worksheet. All of the data I want to transfer starts on the same row but does not always end on a set row. The code I have now will transfer all the data I need, but it does not stop at a blank row before moving on to the next worksheet. It has a set range that it transfers. I need to change the code to record all data on all rows until it reaches a blank row, then move on and do the same with the remaining worksheets. The code I have is:

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


' Change this to the path\folder location of your files.
MyPath = "P:\Custom Windows\Orders\Glass Order\Atrium"


' 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


' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1


' 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(1)
Set sourceRange = .Range("A8:T15")
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)


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


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
.Calculation = CalcMode
End With
End Sub
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
To make your source range dynamic, change this
Code:
Set sourceRange = .Range("A8:T15")
To this
Code:
Set sourceRange = .Range("A8", .Cells(Rows.Count, 20).End(xlUp))
 
Upvote 0
Half of the problem is solved. When I changed the above code I was able to transfer, but it also included the shipping info at the bottom "RUSH" and "CGP TRUCK". I noticed in the code you gave that it starts on Row 8 and checks 20 rows for data. Is there a way that it will continue transferring data, no matter how many rows it is, until it gets to first blank row, then stop and move on to next file?
 
Last edited:
Upvote 0
but it also included the shipping info at the bottom "RUSH" and "CGP TRUCK".

I cannot see your sheet so unless you specify where your data resides, I have no way of knowing. The code I gave starts at row 8 and goes to the last row containing any data. The 20 that you se in the code is the column limit, not the row. Do you want the columns to also be dynamic in the range?

Is there a way that it will continue transferring data, no matter how many rows it is, until it gets to first blank row, then stop and move on to next file?
Which sheet are you referring to? When you have more than one workbook or sheet involved, you need to specify which you refer to for each action, cell, column or row that you talk about. Otherwise, I am guessing at what you want.
 
Last edited:
Upvote 0
I recreated an order sheet below. All of the sheets in the folder to be transferred are formatted as below. There may be more or less order lines than just than below, but all of the sheets have the same space after the last order before RUSH. I would like it to start at Row 8 and transfer all rows below it until it reaches the blank line before RUSH, then move on to next sheet in folder.


_|_____ A_______|_ B_ | C | D | E | F | G | H |
1 Customer Name
2 PO#
3 Delivery Date
4
5
6 __SEQ# QTY GRID Color
7
8 MO41 1 Beige
9 MO42 1 White
10 MO43-MO44 2 White
11 MO45 1 Clay
12
13 RUSH
14
CWP TRUCK
 
Last edited:
Upvote 0
This will modify the entire With statement and add a variable to your declarations, but it appears to be the only way I can get it to treat your source range as a dynamic range

Code:
Dim fn As Range 'In[COLOR=#b22222]sert with other declarations near top of code[/COLOR]
With mybook.Worksheets(1)
    Set fn = .Range("A:A").Find("RUSH", , xlValues, xlWhole)
    If Not fn Is Nothing Then
        Set SourceRange = .Range("A8", fn.End(xlUp).Offset(, 19))
    Else 'Throw in a safety valve here
        MsgBox "Copy Range Not Set, Check Form on Workbook " & mybook.Name
        Exit Sub
    End If
End With
Also, this is untested, so post back if there is a problem.
 
Last edited:
Upvote 0
If I understand right, I am to add "Dim fn As Range" to declarations, then replace the "With mybook.Worksheets(1)" statement with the one provided. I am now getting "Copy Range Not Set, Check Form on Workbook.xls" message.
 
Upvote 0
If I understand right, I am to add "Dim fn As Range" to declarations, then replace the "With mybook.Worksheets(1)" statement with the one provided. I am now getting "Copy Range Not Set, Check Form on Workbook.xls" message.

The declarations statement and replacement are correct. The message appears if the VBA Find statement fails to find the word "RUSH" on your worksheet in column A. To define the range you want without copying the data below it, I assumed from your illustration of the form that RUSH would always be below the data to be copied. Was that a bad assumption? If RUSH is not there, then it gives you the message because it cannot set the copy range.
 
Upvote 0

Forum statistics

Threads
1,213,497
Messages
6,114,002
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top