VBA Macro Syntax Error While Combining Multiple Worksheets (1 Viewer)

E

Escondido

Registered User.
Local time
Yesterday, 21:51
Joined
Oct 16, 2016
Messages
12
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 highlights it as fellow.

I'm not sure what exactly is wrong. I'm hoping somebody might shed some light on the subject and help me solve this problem.

Code: 
Sub MergeExcelFiles()
    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 End Function

Original.xlsx Columns
A-Home Phone
B-First Name
C-Last Name
D-Address
E-Address2
F-City
G-State
H-Zip Code
I-County
J-Birth Month
K-Birth Year
L-Primary DOB
M-Primary Age
N-Source
O-Vertical

Dialed.xlsx Columns
A-lead_id
B-entry_date
C-modify_date
D-status
E-user
F-vendor_lead_code
G-source_id
H-list_id
I-gmt_offset_now
J-called_since_last_reset
K-phone_code
L-phone_number
M-title
N-first_name
O-middle_initial
P-last_name
Q-address1
R-address2
S-address3
T-city
U-state
V-province
W-postal_code
X-country_code
Y-gender
Z-date_of_birth
AA-alt_phone
AB-email
AC-security_phrase
AD-comments
AE-called_count
AF-last_local_call_time
AG-rank
AH-owner
AI-month_birth
AJ-month_year

Original has the primary fields I normally use, while Dialed has some of the same fields and a few additional ones I am trying to add to my final spreadsheet.

Any help would be appreciated.
 
S

sneuberg

AWF VIP
Local time
Yesterday, 19:51
Joined
Oct 17, 2014
Messages
3,506
Is the End Function really on the same line that starts with GetColName as


Code: 
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 End Function

If so change it to


Code: 
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
 End Function

What was the error you were getting?
 
E

Escondido

Registered User.
Local time
Yesterday, 21:51
Joined
Oct 16, 2016
Messages
12
sneuberg said:
Is the End Function really on the same line that starts with GetColName as


Code: 
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 End Function

If so change it to


Code: 
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
 End Function

What was the error you were getting?
Click to expand...

When I click Run a popup appears saying Compile Error: Syntax error

The following 2 lines are red
*Dim colMap As New Collection
*Select Case fileName

After clicking the ok button on the popup Excel automatically adds an arrow and highlights the following line in all yellow.

Function MapColumns(fileName As String) As Object
Original Code copied from Macro

Code: 
Sub MergeExcelFiles()
    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\xxxxxxx\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 "Dialed.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
End Function

I have no idea why the * are showing up in the code above. They are not listed in the macro. I might be wrong, but I think the first 2 lines
Dim colMap As New Collection
Select Case fileName
pertain to the Original.xlsx file while the 2nd set pertains to Dialed.xlsx. I also have no idea why only one set of them is red. I found the code on a website, which appears to be from 14 years ago. Something is not off and this is not my specialty. I followed the directions to a T, but did add in the column info I needed to extract.

The original post is from here

https://www.joinedupdata.com/the-ul...w-to-merge-excel-files-with-different-columns
 
Last edited:
You must log in or register to reply here.

Similar threads

L
Solved VBA Create Query With Long Text(Memo) Field Parameter Errors If More Than 255 Characters
Replies
5
Views
1,568
LGDGlen
L
S
Rename multiple parts of the same file name for all files in a directory
Replies
1
Views
729
theDBguy
theDBguy
C
How do I use a filepath to open a file in VBA?
Replies
11
Views
3,306
theDBguy
theDBguy
P
Error 2501 - The OutputTo action was canceled
Replies
7
Views
2,925
PatAccess
P
R
Error While running SQL Stored procedure thru Access 2010 VBA
Replies
2
Views
1,621
rd.prasanna
R

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Top Bottom