473,327 Members | 1,892 Online
Bytes | Software Development & Data Engineering Community
Post Job

Home Posts Topics Members FAQ

Join Bytes to post your question to a community of 473,327 software developers and data experts.

Combine worksheets

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




Expand|Select|Wrap|Line Numbers
  1. Sub MergeAllSheets()
  2.   Dim rs As Recordset
  3.   Dim mergedRS As Recordset
  4.   Dim sh As Worksheet
  5.   Dim wb As Workbook
  6.  
  7.   Dim fieldList As New Collection
  8.   Dim rsetList As New Collection
  9.  
  10.   Dim f As Variant
  11.   Dim cols As Long
  12.   Dim rows As Long
  13.   Dim c As Long
  14.   Dim r As Long
  15.  
  16.   Dim ref As String
  17.   Dim fldName As String
  18.   Dim sourceColumn As String
  19.  
  20.  
  21.  
  22.   Set wb = ActiveWorkbook
  23.   For Each sh In wb.Worksheets
  24.     Set rs = New Recordset
  25.     ref = FindEndCell(sh)
  26.     cols = sh.Range(ref).Column
  27.     rows = sh.Range(ref).Row
  28.  
  29.     If ref <> "$A$1" Or sh.Range(ref).Value <> "" Then '' This is to catch empty sheet
  30.       c = 1
  31.       r = 1
  32.       Do While c <= cols
  33.         fldName = sh.Cells(r, c).Value
  34.         rs.Fields.Append fldName, adVarChar, MAX_CHARS
  35.         If Not InCollection(fieldList, fldName) Then
  36.           fieldList.Add fldName, fldName
  37.         End If
  38.         c = c + 1
  39.       Loop
  40.       rs.Open
  41.  
  42.  
  43.       r = 2
  44.       Do While r <= rows
  45.         rs.AddNew
  46.         c = 1
  47.         Do While c <= cols
  48.           rs.Fields(c - 1) = CStr(sh.Cells(r, c).Value)
  49.           c = c + 1
  50.         Loop
  51.         r = r + 1
  52.         Debug.Print sh.Name & ": " & r & " of " & rows & ", " & c & " of " & cols
  53.       Loop
  54.       rsetList.Add rs, sh.Name
  55.     End If
  56.   Next
  57.  
  58.  
  59.   Set mergedRS = New Recordset
  60.   c = 1
  61.   sourceColumn = "SourceSheet"
  62.   Do While InCollection(fieldList, sourceColumn) '' Just in case you merge a merged sheet
  63.     sourceColumn = "SourceSheet" & c
  64.     c = c + 1
  65.   Loop
  66.   mergedRS.Fields.Append sourceColumn, adVarChar, MAX_CHARS
  67.   For Each f In fieldList
  68.     mergedRS.Fields.Append CStr(f), adVarChar, MAX_CHARS
  69.   Next
  70.   mergedRS.Open
  71.  
  72.   c = 1
  73.   For Each rs In rsetList
  74.     If rs.RecordCount >= 1 Then
  75.       rs.MoveFirst
  76.       Do Until rs.EOF
  77.         mergedRS.AddNew
  78.         mergedRS.Fields(sourceColumn) = "Sheet No. " & c
  79.         For Each f In rs.Fields
  80.           mergedRS.Fields(f.Name) = f.Value
  81.         Next
  82.         rs.MoveNext
  83.       Loop
  84.     End If
  85.     c = c + 1
  86.   Next
  87.  
  88.  
  89.   Set sh = wb.Worksheets.Add
  90.  
  91.   mergedRS.MoveFirst
  92.   r = 1
  93.   c = 1
  94.   For Each f In mergedRS.Fields
  95.     sh.Cells(r, c).Formula = f.Name
  96.     c = c + 1
  97.   Next
  98.  
  99.   r = 2
  100.   Do Until mergedRS.EOF
  101.     c = 1
  102.     For Each f In mergedRS.Fields
  103.       sh.Cells(r, c).Value = f.Value
  104.       c = c + 1
  105.     Next
  106.     r = r + 1
  107.     mergedRS.MoveNext
  108.   Loop
  109. End Sub
  110.  
  111. Public Function InCollection(col As Collection, key As String) As Boolean
  112.   Dim var As Variant
  113.   Dim errNumber As Long
  114.  
  115.   InCollection = False
  116.   Set var = Nothing
  117.  
  118.   Err.Clear
  119.   On Error Resume Next
  120.     var = col.Item(key)
  121.     errNumber = CLng(Err.Number)
  122.   On Error GoTo 0
  123.  
  124.   '5 is not in, 0 and 438 represent incollection
  125.   If errNumber = 5 Then ' it is 5 if not in collection
  126.     InCollection = False
  127.   Else
  128.     InCollection = True
  129.   End If
  130.  
  131. End Sub
Nov 11 '11 #1
14 1472
Guido Geurs
767 Expert 512MB
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"
Nov 14 '11 #2
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
Attached Files
File Type: zip Bytes.com Combining (2).zip (55.6 KB, 37 views)
Nov 15 '11 #3
Guido Geurs
767 Expert 512MB
This will copy the sheets from all workbooks in the folder:

Expand|Select|Wrap|Line Numbers
  1. Option Explicit
  2.  
  3. Private Sub Workbook_Open()
  4. Dim FILEScount As Integer
  5. Dim WORKBOOKopen As Workbook
  6. Dim WORKBOOKSidx As Integer
  7. Dim ARRAYDATA As Variant
  8. Dim FIRSTblancoROW As String
  9.     '§ Find all files in the folder
  10.     With Application.FileSearch
  11.         .NewSearch
  12.         .SearchSubFolders = False
  13.         .LookIn = ThisWorkbook.Path
  14.         .Execute
  15.         '§ if we found some files to open:
  16.         If .FoundFiles.Count > 0 Then
  17.             '§ Stop screen flicker of workbooks being opened
  18.             Application.ScreenUpdating = False
  19.             '§ Simple loop, opening the workbooks
  20.             For FILEScount = 1 To .FoundFiles.Count
  21.                 If .FoundFiles(FILEScount) <> ThisWorkbook.FullName Then _
  22.                     Set WORKBOOKopen = Workbooks.Open(.FoundFiles(FILEScount))
  23.                 DoEvents
  24.             Next FILEScount
  25.         End If
  26.     End With
  27. '§ Copy sheets
  28.     For WORKBOOKSidx = 1 To Application.Workbooks.Count
  29.         If Application.Workbooks(WORKBOOKSidx).Name <> ThisWorkbook.Name Then
  30.             Workbooks(WORKBOOKSidx).Sheets(1).Activate
  31.             Range("A2").Resize(Range("A2").End(xlDown).Row - 1, 32).Select
  32.             ARRAYDATA = Selection
  33.             Workbooks(ThisWorkbook.Name).Sheets(1).Activate
  34.             If Range("A2").End(xlDown).Address = "$A$65536" Then
  35.                 FIRSTblancoROW = "A2" '§ blanco sheet
  36.             Else
  37.                 FIRSTblancoROW = Range("A2").End(xlDown).Address
  38.             End If
  39.             Range(FIRSTblancoROW).Resize(UBound(ARRAYDATA, 1), UBound(ARRAYDATA, 2)) = ARRAYDATA
  40.         End If
  41.     Next
  42. '§ close workbooks
  43.     For WORKBOOKSidx = Application.Workbooks.Count To 1 Step -1
  44.         If Application.Workbooks(WORKBOOKSidx).Name <> ThisWorkbook.Name Then
  45.             Application.Workbooks(WORKBOOKSidx).Close SaveChanges:=False
  46.         End If
  47.     Next
  48. End Sub
PS:
This is working in Office 2003!
Maybe you have to change the condition of finding the files!?
Attached Files
File Type: zip merge_v2.zip (54.8 KB, 34 views)
Nov 16 '11 #4
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
Expand|Select|Wrap|Line Numbers
  1. Private Sub Workbook_Open()
  2. Dim FILEScount As Integer
  3. Dim WORKBOOKopen As Workbook
  4. Dim WORKBOOKSidx As Integer
  5. Dim ARRAYDATA As Variant
  6. Dim FIRSTblancoROW As String
  7.     '§ Find all files in the folder
  8.     With Application.FileSearch
  9.         .NewSearch
  10.         .SearchSubFolders = False
  11.         .LookIn = ThisWorkbook.Path
  12.         .Execute
  13.         '§ if we found some files to open:
  14.         If .FoundFiles.Count > 0 Then
  15.             '§ Stop screen flicker of workbooks being opened
  16.             Application.ScreenUpdating = False
  17.             '§ Simple loop, opening the workbooks
  18.             For FILEScount = 1 To .FoundFiles.Count
  19.                 If .FoundFiles(FILEScount) <> ThisWorkbook.FullName Then _
  20.                     Set WORKBOOKopen = Workbooks.Open(.FoundFiles(FILEScount))
  21.                 DoEvents
  22.             Next FILEScount
  23.         End If
  24.     End With
  25. '§ Copy sheets
  26.     For WORKBOOKSidx = 1 To Application.Workbooks.Count
  27.         If Application.Workbooks(WORKBOOKSidx).Name <> ThisWorkbook.Name Then
  28.             Workbooks(WORKBOOKSidx).Sheets(1).Activate
  29.             Range("A2").Resize(Range("A2").End(xlDown).Row - 1, 32).Select
  30.             ARRAYDATA = Selection
  31.             Workbooks(ThisWorkbook.Name).Sheets(1).Activate
  32.             If Range("A2").End(xlDown).Address = "$A$65536" Then
  33.                 FIRSTblancoROW = "A2" '§ blanco sheet
  34.             Else
  35.                 FIRSTblancoROW = Range("A2").End(xlDown).Address
  36.             End If
  37.             Range(FIRSTblancoROW).Resize(UBound(ARRAYDATA, 1), UBound(ARRAYDATA, 2)) = ARRAYDATA
  38.         End If
  39.     Next
  40. '§ close workbooks
  41.     For WORKBOOKSidx = Application.Workbooks.Count To 1 Step -1
  42.         If Application.Workbooks(WORKBOOKSidx).Name <> ThisWorkbook.Name Then
  43.             Application.Workbooks(WORKBOOKSidx).Close SaveChanges:=False
  44.         End If
  45.     Next
  46. End Sub
Thanks for helping Appreciated!!!
Nov 16 '11 #5
Guido Geurs
767 Expert 512MB
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)
Expand|Select|Wrap|Line Numbers
  1. Option Explicit
  2.  
  3. Private Sub Workbook_Open()
  4. Dim FILEScount As Integer
  5. Dim WORKBOOKopen As Workbook
  6. Dim WORKBOOKSidx As Integer
  7. Dim ARRAYDATA As Variant
  8. Dim FIRSTblancoROW As String
  9. Dim FILESstring As String
  10. Dim FILEname As String
  11. Dim HOMEfolder As String
  12. Dim ARRfiles() As String
  13.     HOMEfolder = ThisWorkbook.Path
  14. '§ Find all files in the folder
  15.     If Right$(ThisWorkbook.Path, 1) <> "\" Then HOMEfolder = ThisWorkbook.Path & "\"
  16.     '§ first file
  17.     FILESstring = Dir(HOMEfolder & "*.xlsm")
  18.     '§ rest of files
  19.     Do
  20.         FILEname = Dir
  21.         If FILEname = "" Then Exit Do
  22.         If FILEname <> ThisWorkbook.Name Then FILESstring = FILESstring & "|" & FILEname
  23.     Loop
  24.     ARRfiles = Split(FILESstring, "|")
  25.     '§ if we found some files to open:
  26.     If UBound(ARRfiles) > 0 Then
  27.         '§ Stop screen flicker of workbooks being opened
  28.         Application.ScreenUpdating = False
  29.         '§ opening the workbooks
  30.         For FILEScount = LBound(ARRfiles) To UBound(ARRfiles)
  31.             Set WORKBOOKopen = Workbooks.Open(HOMEfolder & ARRfiles(FILEScount))
  32.         Next FILEScount
  33.     End If
  34. '§ Copy sheets
  35.     For WORKBOOKSidx = LBound(ARRfiles) To UBound(ARRfiles)
  36.         Workbooks(ARRfiles(WORKBOOKSidx)).Sheets(1).Activate
  37.         Range("A2").Resize(Range("A2").End(xlDown).Row - 1, 32).Select
  38.         ARRAYDATA = Selection
  39.         Workbooks(ThisWorkbook.Name).Sheets(1).Activate
  40.         If Range("A2").End(xlDown).Address = "$A$1048576" Then
  41.             FIRSTblancoROW = "A2" '§ blanco sheet
  42.         Else
  43.             FIRSTblancoROW = Range("A2").End(xlDown).Address
  44.         End If
  45.         Range(FIRSTblancoROW).Resize(UBound(ARRAYDATA, 1), UBound(ARRAYDATA, 2)) = ARRAYDATA
  46.     Next
  47. '§ close workbooks
  48.     For WORKBOOKSidx = Application.Workbooks.Count To 1 Step -1
  49.         If Application.Workbooks(WORKBOOKSidx).Name <> ThisWorkbook.Name Then
  50.             Application.Workbooks(WORKBOOKSidx).Close SaveChanges:=False
  51.         End If
  52.     Next
  53. '§ ScreenUpdating back on
  54.     Application.ScreenUpdating = True
  55. End Sub
Attached Files
File Type: zip Merge_v3.zip (14.0 KB, 49 views)
Nov 17 '11 #6
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
Nov 17 '11 #7
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
Nov 17 '11 #8
hey Guido he is the workbook i was telling you about....
Attached Files
File Type: zip PLs 23.zip (354.7 KB, 32 views)
Nov 22 '11 #9
Guido Geurs
767 Expert 512MB
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=
Expand|Select|Wrap|Line Numbers
  1. '§ Copy sheets
  2.     For WORKBOOKSidx = 1 To Workbooks.Count
  3.         If Workbooks(WORKBOOKSidx).Name <> ThisWorkbook.Name Then
  4.             Workbooks(WORKBOOKSidx).Sheets(1).Activate
  5.             Range("A2").Resize(Range("A2").End(xlDown).Row - 1, 32).Select
  6.             ARRAYDATA = Selection
  7.             Workbooks(ThisWorkbook.Name).Sheets(1).Activate
  8.             If Range("A2").End(xlDown).Address = "$A$1048576" Or _
  9.                     Range("A2").End(xlDown).Address = "$A$65536" Then
  10.                 FIRSTblancoROW = 2 '§ blanco sheet
  11.             Else
  12.                 FIRSTblancoROW = Range("A2").End(xlDown).Row + 1
  13.             End If
  14.             Range("A" & FIRSTblancoROW).Resize(UBound(ARRAYDATA, 1), UBound(ARRAYDATA, 2)) = ARRAYDATA
  15.         End If
  16.     Next
Nov 26 '11 #10
Guido Geurs
767 Expert 512MB
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.
Expand|Select|Wrap|Line Numbers
  1. ....
  2. '§ Copy sheets
  3. Dim WORKBOOKSidx As Integer
  4. Dim ARRAYHEADER As Variant
  5. Dim ARRAYDATA As Variant
  6. Dim FIRSTblancoROW As String
  7.     For WORKBOOKSidx = 1 To Workbooks.Count
  8.         If Workbooks(WORKBOOKSidx).Name <> ThisWorkbook.Name Then
  9.             '§ FROM workbook
  10.             Workbooks(WORKBOOKSidx).Sheets(1).Activate
  11.             ARRAYHEADER = Range("A1").Resize(1, Range("A1").End(xlToRight).Column)
  12.             ARRAYDATA = Range("A2").Resize(Range("A2").End(xlDown).Row - 1, 32)
  13.             '§ TO workbook
  14.             Workbooks(ThisWorkbook.Name).Sheets(1).Activate
  15.             '§ blanco sheet for version 2003 =>"$A$65536"
  16.             '§ blanco sheet for version 2007 =>"$A$1048576"
  17.             If Range("A2").End(xlDown).Address = "$A$1048576" Or _
  18.                     Range("A2").End(xlDown).Address = "$A$65536" Then
  19.                 FIRSTblancoROW = 2 '§ blanco sheet
  20.                 '§ paste header
  21.                 Range("A1").Resize(1, UBound(ARRAYHEADER, 2)) = ARRAYHEADER
  22.             Else
  23.                 FIRSTblancoROW = Range("A2").End(xlDown).Row + 1
  24.             End If
  25.             Range("A" & FIRSTblancoROW).Resize(UBound(ARRAYDATA, 1), UBound(ARRAYDATA, 2)) = ARRAYDATA
  26.         End If
  27.     Next
  28. ...
Nov 27 '11 #11
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
Nov 28 '11 #12
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
Attached Files
File Type: zip Client Under contract (2).zip (3.85 MB, 35 views)
Dec 13 '11 #13
Guido Geurs
767 Expert 512MB
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".
Dec 13 '11 #14
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!!!!@
Dec 13 '11 #15

Sign in to post your reply or Sign up for a free account.

Similar topics

2
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...
1
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#?
4
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...
1
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...
3
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...
6
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...
7
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 .....
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...
2
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...
2
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...
0
by: ryjfgjl | last post by:
ExcelToDatabase: batch import excel into database automatically...
0
isladogs
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...
1
isladogs
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...
0
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...
1
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...
1
by: Defcon1945 | last post by:
I'm trying to learn Python using Pycharm but import shutil doesn't work
1
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....
0
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...
0
isladogs
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...

By using Bytes.com and it's services, you agree to our Privacy Policy and Terms of Use.

To disable or enable advertisements and analytics tracking please visit the manage ads & tracking page.