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
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
Code:
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
Comment