Trouble with merging Data in one Excell

F_Doorn

New Member
Joined
Nov 21, 2017
Messages
4
Hi,

Today I have tried to set up a VBA code in Excel to merge multiple data into one Excel-file.
I have a Test folder with multiple Excel files and i want to read multiple cells from each file into one New Excel file.

Below an overview of the code. Where I get stuck is reading the multiple cells and placing them in a new file.
I'm probably doing something wrong with the MultipleRange and DestRange. Could somebody help me to find out what I'm doing wrong?

Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim NRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim r1, r2, r3, r4, myMultipleRange As Range
Dim DestRange As Range


' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)


' Modify this folder path to point to the files you want to use.
FolderPath = "C:\Users\603964\Desktop\Test"


' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 1


' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xl*")


' Loop until Dir returns an empty string.
Do While FileName <> ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)


' Set the cell in column A to be the file name.
SummarySheet.Range("A" & NRow).Value = FileName


' Set the source range to be A9 through C9.
' Modify this range for your workbooks.
' It can span multiple rows.
Set r1 = WorkBk.Worksheets(1).Range("A4:C4")
Set r2 = WorkBk.Worksheets(1).Range("A9:C9")
Set r3 = WorkBk.Worksheets(1).Range("A10:C10")
Set r4 = WorkBk.Worksheets(1).Range("A42:C42")
Set myMultipleRange = Union(r1, r2, r3, r4)
' myMultipleRange.Font.Bold = True



' Set the destination range to start at column B and
' be the same size as the source range.
Set DestRange = SummarySheet.Range("B" & NRow)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)


' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value


' Increase NRow so that we know where to copy data next.
NRow = NRow + DestRange.Rows.Count


' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False


' Use Dir to get the next file name.
FileName = Dir()
Loop


' Call AutoFit on the destination sheet so that all
' data is readable.
SummarySheet.Columns.AutoFit
End Sub
 

Some videos you may like

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,384
Office Version
  1. 365
Platform
  1. Windows
Hi, welcome to the board.
Untested, but try
Code:
Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim NRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim Rng As Range, SourceRng As Range
Dim DestRange As Range


' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)


' Modify this folder path to point to the files you want to use.
FolderPath = "C:\Users\603964\Desktop\Test"


' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 1


' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xl*")


' Loop until Dir returns an empty string.
Do While FileName <> ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)


' Set the cell in column A to be the file name.
SummarySheet.Range("A" & NRow).Value = FileName


' Set the source range to be A9 through C9.
' Modify this range for your workbooks.
' It can span multiple rows.
Set SourceRng = WorkBk.Worksheets(1).Range("A4:C4")
Set SourceRng = Union(SourceRng, WorkBk.Worksheets(1).Range("A9:C9"))
Set SourceRng = Union(SourceRng, WorkBk.Worksheets(1).Range("A9:C9"))
Set SourceRng = Union(SourceRng, WorkBk.Worksheets(1).Range("A10:C10"))
Set SourceRng = Union(SourceRng, WorkBk.Worksheets(1).Range("A42:C42"))

' myMultipleRange.Font.Bold = True



' Set the destination range to start at column B and
' be the same size as the source range.
Set DestRange = SummarySheet.Range("B" & NRow)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)


' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value


' Increase NRow so that we know where to copy data next.
NRow = NRow + DestRange.Rows.Count


' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False


' Use Dir to get the next file name.
FileName = Dir()
Loop


' Call AutoFit on the destination sheet so that all
' data is readable.
SummarySheet.Columns.AutoFit
End Sub
 

bellman101

Board Regular
Joined
Aug 20, 2012
Messages
245
Hi folks,

Does it even open the workbooks? Could it be that you are not including the '\' at the end of the folder path, so instead it is looking in the folder 'Desktop' for a file named 'Test*.xl*'?

FolderPath = "C:\Users\603964\Desktop\Test"

Cheers
JB
 

F_Doorn

New Member
Joined
Nov 21, 2017
Messages
4
Hi folks,

Does it even open the workbooks? Could it be that you are not including the '\' at the end of the folder path, so instead it is looking in the folder 'Desktop' for a file named 'Test*.xl*'?

FolderPath = "C:\Users\603964\Desktop\Test"

Cheers
JB

Hi Bellman101,

thanks for your reply! When i want to retrieve one range the code does work.
But when i try to read in multiple ranges it doesn't work.

the folderpath is not the problem in this case.
 

F_Doorn

New Member
Joined
Nov 21, 2017
Messages
4

ADVERTISEMENT

Hi, welcome to the board.
Untested, but try
Code:
Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim NRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim Rng As Range, SourceRng As Range
Dim DestRange As Range


' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)


' Modify this folder path to point to the files you want to use.
FolderPath = "C:\Users\603964\Desktop\Test"


' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 1


' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xl*")


' Loop until Dir returns an empty string.
Do While FileName <> ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)


' Set the cell in column A to be the file name.
SummarySheet.Range("A" & NRow).Value = FileName


' Set the source range to be A9 through C9.
' Modify this range for your workbooks.
' It can span multiple rows.
Set SourceRng = WorkBk.Worksheets(1).Range("A4:C4")
Set SourceRng = Union(SourceRng, WorkBk.Worksheets(1).Range("A9:C9"))
Set SourceRng = Union(SourceRng, WorkBk.Worksheets(1).Range("A9:C9"))
Set SourceRng = Union(SourceRng, WorkBk.Worksheets(1).Range("A10:C10"))
Set SourceRng = Union(SourceRng, WorkBk.Worksheets(1).Range("A42:C42"))

' myMultipleRange.Font.Bold = True



' Set the destination range to start at column B and
' be the same size as the source range.
Set DestRange = SummarySheet.Range("B" & NRow)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)


' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value


' Increase NRow so that we know where to copy data next.
NRow = NRow + DestRange.Rows.Count


' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False


' Use Dir to get the next file name.
FileName = Dir()
Loop


' Call AutoFit on the destination sheet so that all
' data is readable.
SummarySheet.Columns.AutoFit
End Sub

Hi Fluff,

Many thanks for your reply and code.

I have tested the code, but it only open the new worksheet without any output.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,384
Office Version
  1. 365
Platform
  1. Windows
When you run the code, do any workbooks open?
 

F_Doorn

New Member
Joined
Nov 21, 2017
Messages
4
Hi,

Only the new workbook is opened without the output.
I got the following code working. it only gives the output of all files in one workbook, with the value of cells A4: C4.

now I want to select multiple cells from the files that are in the folder, but here I get stuck.
The output needs te be something like this:

Filename 1A9B9C9A10B10C10A42B42C42
Filename 2A9B9C9A10B10C10A42B42C42
Filename 3A9B9C9A10B10C10A42B42C42
Filename 4A9B9C9A10B10C10A42B42C42
Filename 5A9B9C9A10B10C10A42B42C42
Filename 6A9B9C9A10B10C10A42B42C42
Filename 7A9B9C9A10B10C10A42B42C42
Filename 8A9B9C9A10B10C10A42B42C42

<colgroup><col><col span="9"></colgroup><tbody>
</tbody>

Code:

Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim NRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range


' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)


' Modify this folder path to point to the files you want to use.
FolderPath = "C:\Users\603964\Desktop\Test"


' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 1


' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xl*")


' Loop until Dir returns an empty string.
Do While FileName <> ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)


' Set the cell in column A to be the file name.
SummarySheet.Range("A" & NRow).Value = FileName


' Set the source range to be A9 through C9.
' Modify this range for your workbooks.
' It can span multiple rows.
Set SourceRange = WorkBk.Worksheets(1).Range("A4:C4")


' Set the destination range to start at column B and
' be the same size as the source range.
Set DestRange = SummarySheet.Range("B" & NRow)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
SourceRange.Columns.Count)


' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value


' Increase NRow so that we know where to copy data next.
NRow = NRow + DestRange.Rows.Count


' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False


' Use Dir to get the next file name.
FileName = Dir()
Loop


' Call AutoFit on the destination sheet so that all
' data is readable.
SummarySheet.Columns.AutoFit
End Sub
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,384
Office Version
  1. 365
Platform
  1. Windows
Try this
Code:
Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim NRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range


' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)


' Modify this folder path to point to the files you want to use.
FolderPath = "C:\Users\603964\Desktop\Test"


' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 1


' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xl*")


' Loop until Dir returns an empty string.
Do While FileName <> ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)


' Set the cell in column A to be the file name.
SummarySheet.Range("A" & NRow).Value = FileName


' Set the source range to be A9 through C9.
' Modify this range for your workbooks.
' It can span multiple rows.

SummarySheet.Range("B" & NRow).Resize(2, 3).Value = WorkBk.Worksheets(1).Range("A9:C10")
SummarySheet.Range("B" & NRow + 2).Resize(, 3).Value = WorkBk.Worksheets(1).Range("A42:C42")
' Set the destination range to start at column B and
' be the same size as the source range.


' Copy over the values from the source to the destination.


' Increase NRow so that we know where to copy data next.
NRow = NRow + 3

' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False


' Use Dir to get the next file name.
FileName = Dir()
Loop


' Call AutoFit on the destination sheet so that all
' data is readable.
SummarySheet.Columns.AutoFit
End Sub
Also, when posting code please use code tags (the # icon in the reply window)
 

Watch MrExcel Video

Forum statistics

Threads
1,123,519
Messages
5,602,141
Members
414,505
Latest member
quoctrungvu99

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
Top