Trouble with merging Data in one Excell

F

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
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Sort by date Sort by votes
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
 
Upvote 0
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
 
Upvote 0
bellman101 said:
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
Click to expand...

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.
 
Upvote 0
Fluff said:
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
Click to expand...

Hi Fluff,

Many thanks for your reply and code.

I have tested the code, but it only open the new worksheet without any output.
 
Upvote 0
When you run the code, do any workbooks open?
 
Upvote 0
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:

[TABLE="width: 651"]
<colgroup><col><col span="9"></colgroup><tbody>[TR]
[TD]Filename 1[/TD]
[TD]A9[/TD]
[TD]B9[/TD]
[TD]C9[/TD]
[TD]A10[/TD]
[TD]B10[/TD]
[TD]C10[/TD]
[TD]A42[/TD]
[TD]B42[/TD]
[TD]C42[/TD]
[/TR]
[TR]
[TD]Filename 2[/TD]
[TD]A9[/TD]
[TD]B9[/TD]
[TD]C9[/TD]
[TD]A10[/TD]
[TD]B10[/TD]
[TD]C10[/TD]
[TD]A42[/TD]
[TD]B42[/TD]
[TD]C42[/TD]
[/TR]
[TR]
[TD]Filename 3[/TD]
[TD]A9[/TD]
[TD]B9[/TD]
[TD]C9[/TD]
[TD]A10[/TD]
[TD]B10[/TD]
[TD]C10[/TD]
[TD]A42[/TD]
[TD]B42[/TD]
[TD]C42[/TD]
[/TR]
[TR]
[TD]Filename 4[/TD]
[TD]A9[/TD]
[TD]B9[/TD]
[TD]C9[/TD]
[TD]A10[/TD]
[TD]B10[/TD]
[TD]C10[/TD]
[TD]A42[/TD]
[TD]B42[/TD]
[TD]C42[/TD]
[/TR]
[TR]
[TD]Filename 5[/TD]
[TD]A9[/TD]
[TD]B9[/TD]
[TD]C9[/TD]
[TD]A10[/TD]
[TD]B10[/TD]
[TD]C10[/TD]
[TD]A42[/TD]
[TD]B42[/TD]
[TD]C42[/TD]
[/TR]
[TR]
[TD]Filename 6[/TD]
[TD]A9[/TD]
[TD]B9[/TD]
[TD]C9[/TD]
[TD]A10[/TD]
[TD]B10[/TD]
[TD]C10[/TD]
[TD]A42[/TD]
[TD]B42[/TD]
[TD]C42[/TD]
[/TR]
[TR]
[TD]Filename 7[/TD]
[TD]A9[/TD]
[TD]B9[/TD]
[TD]C9[/TD]
[TD]A10[/TD]
[TD]B10[/TD]
[TD]C10[/TD]
[TD]A42[/TD]
[TD]B42[/TD]
[TD]C42[/TD]
[/TR]
[TR]
[TD]Filename 8[/TD]
[TD]A9[/TD]
[TD]B9[/TD]
[TD]C9[/TD]
[TD]A10[/TD]
[TD]B10[/TD]
[TD]C10[/TD]
[TD]A42[/TD]
[TD]B42[/TD]
[TD]C42[/TD]
[/TR]
</tbody>[/TABLE]

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
 
Upvote 0
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)
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
Merge files and keep source formatting.
Replies
9
Views
350
Alex Blakenburg
A
T
  • Solved
Open all files in a folder and run macro
Replies
3
Views
694
Trebor76
T
J
  • Question Question
Append data to master file
Replies
6
Views
354
Alex Blakenburg
A
M
  • Question Question
Data Transfer from Excel to PowerPoint and getting PDF file of PPT
Replies
1
Views
126
Sequoyah
Sequoyah
B
  • Question Question
Excel VBA Searching Unique Variables to Match against Exported Schedule Files to Determine Date
Replies
1
Views
189
sijpie
sijpie

Forum statistics

Threads
1,224,823
Messages
6,181,182
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

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