I have 2 worksheets and I am trying to combine both of them into one worksheet and fill in the extra fields. I found some code online (listed below) and for some reason I am seeing a syntax error when trying to run the macro. Excel automatically goes to the line showing "Function MapColumns(fileName As String) As Object" and I'm not sure what exactly is wrong. I'm hoping somebody might shed some light on the subject and tell me what I am doing wrong.
Code:
[/COLOR][COLOR=#333333]Sub MergeExcelFiles()[/COLOR]
<code style="margin: 0px; padding: 0px; font-style: inherit; font-weight: inherit; line-height: 12px;"> Dim firstRowHeaders As Boolean
Dim columnMap As Collection
Dim fso As Object
Dim dir As Object
Dim filePath As Variant
Dim fileName As String
Dim file As String
Dim wb As Workbook
Dim s As Sheet1
Dim thisSheet As Sheet1
Dim dataRange As Range
Dim insertAtRowNum As Integer
Dim outColName As String
Dim colName As String
Dim fromRange As String
Dim fromRangeToCopy As Range
Dim toRange As String
On Error GoTo ErrMsg
Application.ScreenUpdating = False
firstRowHeaders = True 'Change from True to False if there are no headers in the first row
Set fso = CreateObject("Scripting.FileSystemObject")
'PLEASE NOTE: Change <> to the path to the folder containing your Excel files to merge
Set dir = fso.Getfolder("C:\Users\Johnny\Desktop\MergeExcel")
Set thisSheet = ThisWorkbook.ActiveSheet
'Insert rows after the last used cell in the master spreadsheet
If Application.Version < "12.0" Then 'Excel 2007 introduced more rows
insertAtRowNum = thisSheet.Range("A65536").End(xlUp).Row
Else
insertAtRowNum = thisSheet.Range("A1048576").End(xlUp).Row
End If
'Only offset by 1 if there are current rows with data in them
If thisSheet.UsedRange.Rows.Count > 1 Or Application.CountA(thisSheet.Rows(1)) Then
insertAtRowNum = insertAtRowNum + 1
End If
For Each filePath In dir.Files
fileName = Right(filePath, Len(filePath) - InStrRev(filePath, Application.PathSeparator, , 1))
'Get the map of columns for this file
Set columnMap = MapColumns(fileName)
'Open the spreadsheet in ReadOnly mode
Set wb = Application.Workbooks.Open(filePath, ReadOnly:=True)
For Each sourceSheet In wb.Sheets
'Get the used range (i.e. cells with data) from the opened spreadsheet
If firstRowHeaders Then 'Don't include headers
Dim mr As Integer
mr = sourceSheet.UsedRange.Rows.Count
Set dataRange = sourceSheet.UsedRange.Offset(1, 0).Resize(mr - 1)
Else
Set dataRange = sourceSheet.UsedRange
End If
For Each col In dataRange.Columns
'Get corresponding output column. Empty string means no mapping
colName = GetColName(col.Column)
outColName = GetOutputColumn(columnMap, colName)
If outColName <> "" Then
fromRange = colName & 1 & ":" & colName & dataRange.Rows.Count
Set fromRangeToCopy = dataRange.Range(fromRange)
fromRangeToCopy.Copy
toRange = outColName & insertAtRowNum & ":" & outColName & (insertAtRowNum + fromRangeToCopy.Rows.Count - 1)
thisSheet.Range(toRange).PasteSpecial
End If
Next col
insertAtRowNum = insertAtRowNum + dataRange.Rows.Count
Next sourceSheet
Application.CutCopyMode = False
Next filePath
ThisWorkbook.Save
Set wb = Nothing
#If Mac Then
'Do nothing. Closing workbooks fails on Mac for some reason
#Else
'Close the workbooks except this one
For Each filePath In dir.Files
file = Right(filePath, Len(filePath) - InStrRev(filePath, Application.PathSeparator, , 1))
Workbooks(file).Close SaveChanges:=False
Next filePath
#End If
Application.ScreenUpdating = True
ErrMsg:
If Err.Number <> 0 Then
MsgBox "There was an error. Please try again. [" & Err.Description & "]"
End If
End Sub
Function MapColumns(fileName As String) As Object
Dim colMap As New Collection
Select Case fileName
*Dim colMap As New Collection
****Select Case fileName
****Case "Original.xlsx"
********colMap.Add Key:="A", Item:="A"
********colMap.Add Key:="B", Item:="B"
********colMap.Add Key:="C", Item:="C"
********colMap.Add Key:="D", Item:="D"
********colMap.Add Key:="E", Item:="E"
********colMap.Add Key:="G", Item:="G"
********colMap.Add Key:="H", Item:="H"
********colMap.Add Key:="I", Item:="I"
********colMap.Add Key:="J", Item:="J"
********colMap.Add Key:="K", Item:="K"
********colMap.Add Key:="L", Item:="L"
********colMap.Add Key:="M", Item:="M"
********colMap.Add Key:="N", Item:="N"
********colMap.Add Key:="O", Item:="O"
********colMap.Add Key:="P", Item:="P"
****Case "Dialed1.xlsx"
********colMap.Add Key:="B", Item:="Q"
********colMap.Add Key:="C", Item:="S"
********colMap.Add Key:="D", Item:="T"
********colMap.Add Key:="E", Item:="U"
********colMap.Add Key:="H", Item:="V"
********colMap.Add Key:="N", Item:="B"
********colMap.Add Key:="P", Item:="C"
********colMap.Add Key:="Q", Item:="D"
********colMap.Add Key:="R", Item:="E"
********colMap.Add Key:="T", Item:="F"
********colMap.Add Key:="U", Item:="G"
********colMap.Add Key:="W", Item:="H"
********colMap.Add Key:="AE", Item:="W"
********colMap.Add Key:="AD", Item:="X"
End Select
Set MapColumns = colMap
End Function
Function GetOutputColumn(columnMap As Collection, col As String) As String
Dim outCol As String
outCol = ""
If columnMap.Count > 0 Then
outCol = columnMap.Item(col)
End If
GetOutputColumn = outCol
End Function
'From: http://www.mrexcel.com/forum/excel-questions/16444-getting-column-name-given-column-number.html
Function GetColName(ColumnNumber)
FuncRange = Cells(1, ColumnNumber).AddressLocal(False, False) 'Creates Range (defaults Row to 1) and retuns Range in xlA1 format
FuncColLength = Len(FuncRange) 'finds length of range reference
GetColName = Left(FuncRange, FuncColLength - 1) 'row always "1" therefore take 1 away from string length and you are left with column ref </code>[COLOR=#333333]End Function[/COLOR][COLOR=#333333]
