Good Morning Everyone.
i would like to merge 6 workbook together they are all the same format all with the same headers and are all in the same folder called merged. I have this code ( below) but i keep getting User defined error on line 3and i dont understand why... Some please help me merge these files together i would appreciate it sooo much
Thanks - Sub MergeAllSheets()
-
Dim rs As Recordset
-
Dim mergedRS As Recordset
-
Dim sh As Worksheet
-
Dim wb As Workbook
-
-
Dim fieldList As New Collection
-
Dim rsetList As New Collection
-
-
Dim f As Variant
-
Dim cols As Long
-
Dim rows As Long
-
Dim c As Long
-
Dim r As Long
-
-
Dim ref As String
-
Dim fldName As String
-
Dim sourceColumn As String
-
-
-
-
Set wb = ActiveWorkbook
-
For Each sh In wb.Worksheets
-
Set rs = New Recordset
-
ref = FindEndCell(sh)
-
cols = sh.Range(ref).Column
-
rows = sh.Range(ref).Row
-
-
If ref <> "$A$1" Or sh.Range(ref).Value <> "" Then '' This is to catch empty sheet
-
c = 1
-
r = 1
-
Do While c <= cols
-
fldName = sh.Cells(r, c).Value
-
rs.Fields.Append fldName, adVarChar, MAX_CHARS
-
If Not InCollection(fieldList, fldName) Then
-
fieldList.Add fldName, fldName
-
End If
-
c = c + 1
-
Loop
-
rs.Open
-
-
-
r = 2
-
Do While r <= rows
-
rs.AddNew
-
c = 1
-
Do While c <= cols
-
rs.Fields(c - 1) = CStr(sh.Cells(r, c).Value)
-
c = c + 1
-
Loop
-
r = r + 1
-
Debug.Print sh.Name & ": " & r & " of " & rows & ", " & c & " of " & cols
-
Loop
-
rsetList.Add rs, sh.Name
-
End If
-
Next
-
-
-
Set mergedRS = New Recordset
-
c = 1
-
sourceColumn = "SourceSheet"
-
Do While InCollection(fieldList, sourceColumn) '' Just in case you merge a merged sheet
-
sourceColumn = "SourceSheet" & c
-
c = c + 1
-
Loop
-
mergedRS.Fields.Append sourceColumn, adVarChar, MAX_CHARS
-
For Each f In fieldList
-
mergedRS.Fields.Append CStr(f), adVarChar, MAX_CHARS
-
Next
-
mergedRS.Open
-
-
c = 1
-
For Each rs In rsetList
-
If rs.RecordCount >= 1 Then
-
rs.MoveFirst
-
Do Until rs.EOF
-
mergedRS.AddNew
-
mergedRS.Fields(sourceColumn) = "Sheet No. " & c
-
For Each f In rs.Fields
-
mergedRS.Fields(f.Name) = f.Value
-
Next
-
rs.MoveNext
-
Loop
-
End If
-
c = c + 1
-
Next
-
-
-
Set sh = wb.Worksheets.Add
-
-
mergedRS.MoveFirst
-
r = 1
-
c = 1
-
For Each f In mergedRS.Fields
-
sh.Cells(r, c).Formula = f.Name
-
c = c + 1
-
Next
-
-
r = 2
-
Do Until mergedRS.EOF
-
c = 1
-
For Each f In mergedRS.Fields
-
sh.Cells(r, c).Value = f.Value
-
c = c + 1
-
Next
-
r = r + 1
-
mergedRS.MoveNext
-
Loop
-
End Sub
-
-
Public Function InCollection(col As Collection, key As String) As Boolean
-
Dim var As Variant
-
Dim errNumber As Long
-
-
InCollection = False
-
Set var = Nothing
-
-
Err.Clear
-
On Error Resume Next
-
var = col.Item(key)
-
errNumber = CLng(Err.Number)
-
On Error GoTo 0
-
-
'5 is not in, 0 and 438 represent incollection
-
If errNumber = 5 Then ' it is 5 if not in collection
-
InCollection = False
-
Else
-
InCollection = True
-
End If
-
-
End Sub
14 1472
When the dim type not shows automatically or when it gives an error, it means that it is not recognized in VBA.
You have to inset the Reference: "Microsoft DAO 3.6 object library" with the class "recordset"
Hello Guido, Thanks for the respone. I am having the worst time figuring this out I have tried i think almost everything for the past week I am serious thinking of converting to Access for this because i cannot combine the worksheet and keep the source from the orginal, If a change is made on the orginal then it refelts on the Master copy. I would like to be able to Combine all workbooks in the same folder. I think that my table is all ready in array. I have attached a the workbook is this some thing that can be done
This will copy the sheets from all workbooks in the folder: - Option Explicit
-
-
Private Sub Workbook_Open()
-
Dim FILEScount As Integer
-
Dim WORKBOOKopen As Workbook
-
Dim WORKBOOKSidx As Integer
-
Dim ARRAYDATA As Variant
-
Dim FIRSTblancoROW As String
-
'§ Find all files in the folder
-
With Application.FileSearch
-
.NewSearch
-
.SearchSubFolders = False
-
.LookIn = ThisWorkbook.Path
-
.Execute
-
'§ if we found some files to open:
-
If .FoundFiles.Count > 0 Then
-
'§ Stop screen flicker of workbooks being opened
-
Application.ScreenUpdating = False
-
'§ Simple loop, opening the workbooks
-
For FILEScount = 1 To .FoundFiles.Count
-
If .FoundFiles(FILEScount) <> ThisWorkbook.FullName Then _
-
Set WORKBOOKopen = Workbooks.Open(.FoundFiles(FILEScount))
-
DoEvents
-
Next FILEScount
-
End If
-
End With
-
'§ Copy sheets
-
For WORKBOOKSidx = 1 To Application.Workbooks.Count
-
If Application.Workbooks(WORKBOOKSidx).Name <> ThisWorkbook.Name Then
-
Workbooks(WORKBOOKSidx).Sheets(1).Activate
-
Range("A2").Resize(Range("A2").End(xlDown).Row - 1, 32).Select
-
ARRAYDATA = Selection
-
Workbooks(ThisWorkbook.Name).Sheets(1).Activate
-
If Range("A2").End(xlDown).Address = "$A$65536" Then
-
FIRSTblancoROW = "A2" '§ blanco sheet
-
Else
-
FIRSTblancoROW = Range("A2").End(xlDown).Address
-
End If
-
Range(FIRSTblancoROW).Resize(UBound(ARRAYDATA, 1), UBound(ARRAYDATA, 2)) = ARRAYDATA
-
End If
-
Next
-
'§ close workbooks
-
For WORKBOOKSidx = Application.Workbooks.Count To 1 Step -1
-
If Application.Workbooks(WORKBOOKSidx).Name <> ThisWorkbook.Name Then
-
Application.Workbooks(WORKBOOKSidx).Close SaveChanges:=False
-
End If
-
Next
-
End Sub
PS:
This is working in Office 2003!
Maybe you have to change the condition of finding the files!?
As soon I opened the file an error message popped up "Object Doeesn't Support this action" and the highlighted line is
Line 8: "With Application.fileSearch". I dont know what that means???? Im using 2010 How can I fix that - Private Sub Workbook_Open()
-
Dim FILEScount As Integer
-
Dim WORKBOOKopen As Workbook
-
Dim WORKBOOKSidx As Integer
-
Dim ARRAYDATA As Variant
-
Dim FIRSTblancoROW As String
-
'§ Find all files in the folder
-
With Application.FileSearch
-
.NewSearch
-
.SearchSubFolders = False
-
.LookIn = ThisWorkbook.Path
-
.Execute
-
'§ if we found some files to open:
-
If .FoundFiles.Count > 0 Then
-
'§ Stop screen flicker of workbooks being opened
-
Application.ScreenUpdating = False
-
'§ Simple loop, opening the workbooks
-
For FILEScount = 1 To .FoundFiles.Count
-
If .FoundFiles(FILEScount) <> ThisWorkbook.FullName Then _
-
Set WORKBOOKopen = Workbooks.Open(.FoundFiles(FILEScount))
-
DoEvents
-
Next FILEScount
-
End If
-
End With
-
'§ Copy sheets
-
For WORKBOOKSidx = 1 To Application.Workbooks.Count
-
If Application.Workbooks(WORKBOOKSidx).Name <> ThisWorkbook.Name Then
-
Workbooks(WORKBOOKSidx).Sheets(1).Activate
-
Range("A2").Resize(Range("A2").End(xlDown).Row - 1, 32).Select
-
ARRAYDATA = Selection
-
Workbooks(ThisWorkbook.Name).Sheets(1).Activate
-
If Range("A2").End(xlDown).Address = "$A$65536" Then
-
FIRSTblancoROW = "A2" '§ blanco sheet
-
Else
-
FIRSTblancoROW = Range("A2").End(xlDown).Address
-
End If
-
Range(FIRSTblancoROW).Resize(UBound(ARRAYDATA, 1), UBound(ARRAYDATA, 2)) = ARRAYDATA
-
End If
-
Next
-
'§ close workbooks
-
For WORKBOOKSidx = Application.Workbooks.Count To 1 Step -1
-
If Application.Workbooks(WORKBOOKSidx).Name <> ThisWorkbook.Name Then
-
Application.Workbooks(WORKBOOKSidx).Close SaveChanges:=False
-
End If
-
Next
-
End Sub
Thanks for helping Appreciated!!!
FileSearch is not supported any more in 2007 or later.
(I have found a lot of angry people on the net because of this ;D).
This is a work around with Dir: (is not working for 2003) - Option Explicit
-
-
Private Sub Workbook_Open()
-
Dim FILEScount As Integer
-
Dim WORKBOOKopen As Workbook
-
Dim WORKBOOKSidx As Integer
-
Dim ARRAYDATA As Variant
-
Dim FIRSTblancoROW As String
-
Dim FILESstring As String
-
Dim FILEname As String
-
Dim HOMEfolder As String
-
Dim ARRfiles() As String
-
HOMEfolder = ThisWorkbook.Path
-
'§ Find all files in the folder
-
If Right$(ThisWorkbook.Path, 1) <> "\" Then HOMEfolder = ThisWorkbook.Path & "\"
-
'§ first file
-
FILESstring = Dir(HOMEfolder & "*.xlsm")
-
'§ rest of files
-
Do
-
FILEname = Dir
-
If FILEname = "" Then Exit Do
-
If FILEname <> ThisWorkbook.Name Then FILESstring = FILESstring & "|" & FILEname
-
Loop
-
ARRfiles = Split(FILESstring, "|")
-
'§ if we found some files to open:
-
If UBound(ARRfiles) > 0 Then
-
'§ Stop screen flicker of workbooks being opened
-
Application.ScreenUpdating = False
-
'§ opening the workbooks
-
For FILEScount = LBound(ARRfiles) To UBound(ARRfiles)
-
Set WORKBOOKopen = Workbooks.Open(HOMEfolder & ARRfiles(FILEScount))
-
Next FILEScount
-
End If
-
'§ Copy sheets
-
For WORKBOOKSidx = LBound(ARRfiles) To UBound(ARRfiles)
-
Workbooks(ARRfiles(WORKBOOKSidx)).Sheets(1).Activate
-
Range("A2").Resize(Range("A2").End(xlDown).Row - 1, 32).Select
-
ARRAYDATA = Selection
-
Workbooks(ThisWorkbook.Name).Sheets(1).Activate
-
If Range("A2").End(xlDown).Address = "$A$1048576" Then
-
FIRSTblancoROW = "A2" '§ blanco sheet
-
Else
-
FIRSTblancoROW = Range("A2").End(xlDown).Address
-
End If
-
Range(FIRSTblancoROW).Resize(UBound(ARRAYDATA, 1), UBound(ARRAYDATA, 2)) = ARRAYDATA
-
Next
-
'§ close workbooks
-
For WORKBOOKSidx = Application.Workbooks.Count To 1 Step -1
-
If Application.Workbooks(WORKBOOKSidx).Name <> ThisWorkbook.Name Then
-
Application.Workbooks(WORKBOOKSidx).Close SaveChanges:=False
-
End If
-
Next
-
'§ ScreenUpdating back on
-
Application.ScreenUpdating = True
-
End Sub
Wow thanks this is merged perfectly I am very happy with the result!!! thanks so much Giudo for helping with this. You Made My DAY!!!!! :-) aHH i AM SOO HAPPY
omg!!! thanks Guido for helping me with this it merged perfectly now with no problems at all Does this update everytime i open the document? Thanks so much you Seriously made my day... :-) One question???? How do i get the heading for the first page to come ove as well and thats it
hey Guido he is the workbook i was telling you about....
Sorry for the error (my mistake) it's not the last line that is not transfered but the next dump who is overwriting the last line of the previous dump.
The FIRSTblancoROW must be +1
This is the correct code= - '§ Copy sheets
-
For WORKBOOKSidx = 1 To Workbooks.Count
-
If Workbooks(WORKBOOKSidx).Name <> ThisWorkbook.Name Then
-
Workbooks(WORKBOOKSidx).Sheets(1).Activate
-
Range("A2").Resize(Range("A2").End(xlDown).Row - 1, 32).Select
-
ARRAYDATA = Selection
-
Workbooks(ThisWorkbook.Name).Sheets(1).Activate
-
If Range("A2").End(xlDown).Address = "$A$1048576" Or _
-
Range("A2").End(xlDown).Address = "$A$65536" Then
-
FIRSTblancoROW = 2 '§ blanco sheet
-
Else
-
FIRSTblancoROW = Range("A2").End(xlDown).Row + 1
-
End If
-
Range("A" & FIRSTblancoROW).Resize(UBound(ARRAYDATA, 1), UBound(ARRAYDATA, 2)) = ARRAYDATA
-
End If
-
Next
This is the code for getting the first row:
When you start on a blanco sheet, put the first row in an array and paste it to the sheet. - ....
-
'§ Copy sheets
-
Dim WORKBOOKSidx As Integer
-
Dim ARRAYHEADER As Variant
-
Dim ARRAYDATA As Variant
-
Dim FIRSTblancoROW As String
-
For WORKBOOKSidx = 1 To Workbooks.Count
-
If Workbooks(WORKBOOKSidx).Name <> ThisWorkbook.Name Then
-
'§ FROM workbook
-
Workbooks(WORKBOOKSidx).Sheets(1).Activate
-
ARRAYHEADER = Range("A1").Resize(1, Range("A1").End(xlToRight).Column)
-
ARRAYDATA = Range("A2").Resize(Range("A2").End(xlDown).Row - 1, 32)
-
'§ TO workbook
-
Workbooks(ThisWorkbook.Name).Sheets(1).Activate
-
'§ blanco sheet for version 2003 =>"$A$65536"
-
'§ blanco sheet for version 2007 =>"$A$1048576"
-
If Range("A2").End(xlDown).Address = "$A$1048576" Or _
-
Range("A2").End(xlDown).Address = "$A$65536" Then
-
FIRSTblancoROW = 2 '§ blanco sheet
-
'§ paste header
-
Range("A1").Resize(1, UBound(ARRAYHEADER, 2)) = ARRAYHEADER
-
Else
-
FIRSTblancoROW = Range("A2").End(xlDown).Row + 1
-
End If
-
Range("A" & FIRSTblancoROW).Resize(UBound(ARRAYDATA, 1), UBound(ARRAYDATA, 2)) = ARRAYDATA
-
End If
-
Next
-
...
Thanks Guido for helping me with this sorry for the late respone I was Very busy over the weekend and wasnt able to get to a computer. I was able to use the code u gave me for getting the last row dumped in the merge file and it worked perfectly!!! I also Changed a few lines that allow me to grab the headers but it didnt work correctly because it took the headers from a of the documents in the folder idk how to add the code above to the only i already have without recieving error message
Hello Guido, I would soo apperciate the help with this i have spent days trying to find out what is the problem. one speadsheet is not merging into the combine worksheet for some reason and i dont know why. so far i have 2 practicelink and file 1. File 1 is not merging into Merge_v3
The workbook "File1" has no data in the column "A" so the code with "Range("A2")...." and ".End(xlDown)" is not working.
A solution is to put data like a string or a number (any data) in the column "A" for each record (row).
An other option is to write a tool in which you determin the range in each file to transfer to the workbook "merge".
OK thanks guido thanks for the fast respone....
I like the idea of puting in a range column k to the last row because i really only use the columns.
Again thank you!!!!@
Sign in to post your reply or Sign up for a free account.
Similar topics
by: JMCN |
last post by:
hello,
i have two worksheets that i need to import from a workbook that has a
total of 5 worksheets. i tried to use this line of code but i run into
an error message that it cannot find the...
|
by: Dan |
last post by:
I have a c# app that creates and Excel doc, I would like
to know how to create new worksheets (tabs) in the excel
doc using c#?
|
by: paul.chae |
last post by:
I have a table in Access with about 3000 records. There are ~60 unique
values in the ID field for the 3000 records. What I would like to do
is automatically generate multiple Excel worksheets...
|
by: J Daniel Melton |
last post by:
Hello,
I am using late binding in a managed VC++ .NET 2003 application. I used KB
302902 (for C#) as a starting point and converted it to managed C++. I built
a managed class that is intantiated...
|
by: mike11d11 |
last post by:
I was able to create three worksheets in my workbook, but when I go to
add the 4th I get an Invalid Index error. I must be leaving something
out to when adding 4 or more sheets. Thanks
Dim...
|
by: Peter Plate |
last post by:
Hi all.
I have a system which operates on Windows MSSQL.
It is used for registering Suppotr requests. The system works with different Tables inside a Database.
One of the tables is for new...
|
by: Claudia d'Amato |
last post by:
I would like to do something in a *.vbs script and all the operations should be applied
on each worksheet within an Excel file.
How do I do this?
It must be something like:
for i in (1 .....
|
by: MarkDotNet |
last post by:
Hi
I am trying to switch Excel worksheets in VBA. I get an error saying "subscript out of range". Please Help- Here is code (Fails on last 2 lines- Note that I ommited the recordset portion of...
|
by: timleonard |
last post by:
I am trying to copy the contents of 6 to 10 worksheets and paste them into one called "coverpage" I have been working with the following code, I've managed to get it to paste data to the coverpage...
|
by: patrick keady |
last post by:
This feels simple. But not enough coffee I suppose. Cant get it to work.
I have about ten worksheets in a workbook. The first worksheet is where I want ROWS returned to from the other 9...
|
by: ryjfgjl |
last post by:
ExcelToDatabase: batch import excel into database automatically...
|
by: isladogs |
last post by:
The next Access Europe meeting will be on Wednesday 6 Mar 2024 starting at 18:00 UK time (6PM UTC) and finishing at about 19:15 (7.15PM).
In this month's session, we are pleased to welcome back...
|
by: isladogs |
last post by:
The next Access Europe meeting will be on Wednesday 6 Mar 2024 starting at 18:00 UK time (6PM UTC) and finishing at about 19:15 (7.15PM).
In this month's session, we are pleased to welcome back...
|
by: ArrayDB |
last post by:
The error message I've encountered is; ERROR:root:Error generating model response: exception: access violation writing 0x0000000000005140, which seems to be indicative of an access violation...
|
by: CloudSolutions |
last post by:
Introduction:
For many beginners and individual users, requiring a credit card and email registration may pose a barrier when starting to use cloud servers. However, some cloud server providers now...
|
by: Defcon1945 |
last post by:
I'm trying to learn Python using Pycharm but import shutil doesn't work
|
by: Shællîpôpï 09 |
last post by:
If u are using a keypad phone, how do u turn on JavaScript, to access features like WhatsApp, Facebook, Instagram....
|
by: Faith0G |
last post by:
I am starting a new it consulting business and it's been a while since I setup a new website. Is wordpress still the best web based software for hosting a 5 page website? The webpages will be...
|
by: isladogs |
last post by:
The next Access Europe User Group meeting will be on Wednesday 3 Apr 2024 starting at 18:00 UK time (6PM UTC+1) and finishing by 19:30 (7.30PM).
In this session, we are pleased to welcome former...
| |