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

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
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:

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

C
  • Solved
Macro works for one file, does not work for all files in the directory
2
Replies
13
Views
460
Alex Blakenburg
A
G
  • Solved
Change Macro to import files from hyperlinks
2
Replies
12
Views
398
GarnesGambit
G
J
  • Question
Power Query - Data Refresh Error in Macro
Replies
3
Views
117
bobsan42
bobsan42
J
  • Question
VBA Script - Can't figure out one error...
2
Replies
15
Views
207
Peter_SSs
Peter_SSs
G
  • Solved
Dir(FolderPath) - multiple file formats
Replies
1
Views
316
DanteAmor
DanteAmor

Forum statistics

Threads
1,214,649
Messages
6,120,728
Members
448,987
Latest member
marion_davis

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