# Combine data range from multiple workbooks into one worksheet with additional variable

#### jessrabbit

##### New Member
Hello, I have searched for a solution to this requirement in the many examples which exist but can't find one that does what I need exactly and my vba skills are not good enough to adapt. I would greatly appreciate help from the excel expert community.

I'm trying to combine several BOM files into one worksheet which I can then use with a pivot table. All workbooks are located in one folder. The source workbooks are based upon the existence of several top level part no BOMs - each contains the enquiry date and top level part no in specific cells (A1 & B6) and then the BOM itself starts at row 12 in cells B12:ARx where the number of rows is a variable but the relevant rows always have a number in column B. If there isn't a number in column B from row 12 then the data isn't required. There is only one worksheet containing the BOM for a specific top level part number in each workbook.

The sequence would be;

1. Value of cell A1, B6 and data in range B12:ARx copied.
2. Data pasted into workbook containing the macro (which is located in a different folder to the source data workbooks) such that Cell values of A1 & B6 are repeated on each row pasted. Data from workbook 2 would be pasted under data from workbook 1 etc.
3. Close source workbook and open next workbook, repeat until all workbooks have been processed in the same way.

Please could somebody get me started with this or point me in the right direction?

Thank you,

Jess

### Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.

#### jessrabbit

##### New Member
I have this code and wonder if it is a suitable starting point for modification.

The code below copies a specific range of data contained in multiple workbooks and pastes it as a picture into several worksheets in one workbook.

The new code should still take data from multiple workbooks but combine it into a single worksheet. Other differences are 1. the need to carry over the date and top level part number from specific cells and 2. the need to only copy data from row 12 on condition that column b contains a number.

Again, any help would be great. Thank you, Jess

Code:
Option Explicit

Const FOLDER_PATH = "C:\Users\(LIVE SOURCE)\"    'Must have the Backslash

Sub ImportWorksheets()
'=============================================
'Process all Excel files in specified folder
'=============================================
Dim sFile As String 'file to process
Dim wsTarget As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long 'output row
'
Dim wbTarget As Workbook

Set wbTarget = ThisWorkbook

'check the folder exists
If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If

Application.ScreenUpdating = False

'loop through the Excel files in the folder
sFile = Dir(FOLDER_PATH & "*.xlsx*")
Do Until sFile = ""

'open the source file and set the source worksheet
Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
Set wsSource = wbSource.Worksheets("Dashboard")

'import the data
wsSource.Range("B2:Z62").Copy
Set wsTarget = wbTarget.ActiveSheet
wbTarget.Activate
wsTarget.Select
ActiveSheet.Pictures.Paste.Select
ActiveSheet.Shapes.Range(Array("Picture 1")).Select
ActiveWindow.DisplayGridlines = False
wsTarget.Name = Replace(sFile, ".xlsx", "")

'close the source workbook, increment the output row and get the next file
wbSource.Close SaveChanges:=False
sFile = Dir()
Loop

Application.ScreenUpdating = True
'tidy up
Set wsSource = Nothing
Set wbSource = Nothing
Set wbTarget = Nothing
Set wsTarget = Nothing
End Sub
'
Private Function FileFolderExists(strPath As String) As Boolean
If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function

Last edited:

#### jessrabbit

##### New Member
Hello, is anyone able to help with this please?

Thank you

#### GR00007

##### Board Regular
This seems to work - it copies A12:N last row, just change N to AR
Code:
Sub BOM()
'
' BOM Macro
'   Housekeeping
Dim sFile As String
Dim wbTarget As Workbook
Dim wbSource As Workbook
Dim wsTarget As Worksheet
Dim wsSource As Worksheet
Dim vRow As Long
Dim vLR As Long
vRow = 2
vPath = "C:\Me\Junk\Test\"
vFileLike = "BOM*.xlsx"
tFile = ThisWorkbook.Name
Set wbTarget = ThisWorkbook
Set wsTarget = wbTarget.Worksheets("CombinedBOM")
'   Get directory
sFile = Dir(vPath & vFileLike)
If sFile = "" Then
MsgBox "No files found, exiting!"
Exit Sub
End If
Do Until sFile = ""
'Open source and find last row
Set wbSource = Workbooks.Open(vPath & sFile)
Set wsSource = wbSource.Worksheets("Sheet1")
vLR = ActiveSheet.UsedRange.Rows.Count
'Copy A1 and B6 from source to current row A & B
wsTarget.Cells(vRow, "A") = wsSource.Cells(1, "A")
wsTarget.Cells(vRow, "B") = wsSource.Cells(6, "B")
'Activate source, filter on column B to exclude blank values
Windows(sFile).Activate
Rows("11:11").Select
Selection.AutoFilter
ActiveSheet.Range("$A$11:$N$" & vLR).AutoFilter Field:=2, Criteria1:="<>", Operator:=xlAnd
'Count filtered rows, select filtered source columns and copy
vFilteredRows = Range("A12:A" & vLR).SpecialCells(xlCellTypeVisible).Count
Range("A12:N" & vLR).Select
Selection.Copy
'Activate target, paste copied range to current row column C
Windows(tFile).Activate
Range("C" & vRow).Select
ActiveSheet.Paste
'Turn off 'marching ants' of copy
Application.CutCopyMode = False
'Select and fill values in A&B for the number of visible rows less one.
Range("A" & vRow & ":B" & vRow).Select
Selection.AutoFill Destination:=Range("A" & vRow & ":B" & vRow + (vFilteredRows - 1)), Type:=xlFillDefault
'Activate and close source without saving
Application.CutCopyMode = False
Windows(sFile).Activate
ActiveWindow.Close
'prepare for next loop, reset current row and obtain next file in directory
vRow = vRow + vFilteredRows
sFile = Dir
Loop
End Sub

Last edited:

#### John_w

##### MrExcel MVP

You haven't said exactly where A1, B6 and B12:ARx should be copied to in the macro workbook. Also, how does the code know which sheet in the source workbook contains the data to be copied?

See if this works as required. A1 is copied to column A, B6 is copied to column B, and B12:ARx are copied to column C and adjacent columns. The data is copied from the first sheet in each workbook.

Code:
Public Sub Copy_Range_From_Workbooks()

Dim folderPath As String, fileName As String
Dim destRow As Long
Dim BOMwb As Workbook
Dim lastRow  As Long

'Folder containing the workbooks

folderPath = "C:\path\to\folder\"                                 'CHANGE THIS

If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
destRow = 1
Application.ScreenUpdating = False
fileName = Dir(folderPath & "*.xlsx")
Do While fileName <> vbNullString
Set BOMwb = Workbooks.Open(folderPath & fileName, ReadOnly:=True)
With BOMwb.Worksheets(1)
If IsNumeric(.Range("B12").Value) Then
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
ThisWorkbook.ActiveSheet.Cells(destRow, "A").Resize(lastRow - 12 + 1).Value = .Range("A1").Value
ThisWorkbook.ActiveSheet.Cells(destRow, "B").Resize(lastRow - 12 + 1).Value = .Range("B6").Value
.Range("B12:AR" & lastRow).Copy ThisWorkbook.ActiveSheet.Cells(destRow, "C")
destRow = destRow + lastRow - 12 + 1
End If
End With
BOMwb.Close False
DoEvents
fileName = Dir
Loop
Application.ScreenUpdating = True

MsgBox "Finished"

End Sub

#### jessrabbit

##### New Member
You are right, I didn't specify but you have put them exactly where I wanted them and the code works perfectly. Please would you let me know how to make one modification so that the data is pasted into sheet2 in the new workbook?

Thank you very much,

Jess

#### jessrabbit

##### New Member

I've just noticed something else. May I also ask for help to preserve numerical values in the source worksheets as numbers in the new worksheet please?

Thank you,

Jess

#### John_w

##### MrExcel MVP
You are right, I didn't specify but you have put them exactly where I wanted them and the code works perfectly. Please would you let me know how to make one modification so that the data is pasted into sheet2 in the new workbook?
Add this line after the ScreenUpdating = False.
Code:
ThisWorkbook.Worksheets(2).Activate

I've just noticed something else. May I also ask for help to preserve numerical values in the source worksheets as numbers in the new worksheet please?
In my testing, all numerical values are copied and preserved as numerical values in the destination sheet. Can you give examples where this doesn't happen?

#### jessrabbit

##### New Member
Thank you very much for the additional line of code to introduce Sheet2 which works great and the numerical format problem has also been resolved.

Best wishes,

Jess

Replies
0
Views
59
Replies
5
Views
665
Replies
8
Views
179
Replies
11
Views
677
Replies
15
Views
191

1,127,567
Messages
5,625,568
Members
416,118
Latest member
kamil_tuncer

### 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.

### Which adblocker are you using?

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

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