Setting a Column Value Using 'Range' is Giving An Error - excel

Question

The below code copies data from multiple worksheets and consolidates into database (database worksheet). I am trying to add a new column at the last unused column of database worksheet that gives the name of the sheets in each row, the data is copied from with the column header as "Sheet Name". The problem is, I am trying to start with adding the header by using wsData.Range(1, wsData.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)).Value = "SheetName", but unfortunately, it is giving an error.
The program is currently taking 6 minutes to process around 25,000 rows, so is there a way to make it faster?
I am not very well-versed with VBA and I received the below code from another stack overflow question. Below is my code. Any help will be appreciated.
Sub ProcessWorkbooks()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim f, wsData As Worksheet, wbSrc As Workbook, map As Object
Set wsData = ThisWorkbook.Sheets("Database")
wsData.UsedRange.ClearContents 'clear any existing data
Dim fldr1 As FileDialog
Dim iFile As String
Set fldr1 = Application.FileDialog(msoFileDialogFolderPicker)
With fldr1
.Title = "Select InputFile Folder... "
.ButtonName = "Select"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show = -1 Then
iFile = .SelectedItems(1)
Else
Exit Sub
End If
End With
Dim strPath As String
strPath = iFile
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(strPath)
Dim abc As Boolean
abc = False
For Each oFile In oFolder.Files
If oFile.Name Like "*xls*" Then
Set wbSrc = Workbooks.Open(oFolder & "\" & oFile.Name)
ImportData wbSrc, wsData, abc
wbSrc.Close False
End If
Next oFile
With wsData.Range("A1").CurrentRegion
.Font.Size = 9
.Font.Name = "Calibri"
.Borders.LineStyle = xlLineStyleNone
.EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
MsgBox Title:="Task Box", Prompt:="Database Created!"
End Sub
Sub ImportData(wbIn As Workbook, wsData As Worksheet, abc as Boolean)
Dim lrData As Long, lrSrc As Long, ws As Worksheet, c As Range
Dim Process, hdr, m, n
Process = Array("Manila", "Cebu", "Davao", "CDO", "Bacolod")
Application.ScreenUpdating = False
For Each ws In wbIn.Worksheets
Call KillFilter
n = ws.Name
lrData = wsData.Cells(Rows.Count, "A").End(xlUp).Row + 1
'lrData = SheetLastRow(wsData) + 1
If lrData = 1 Then lrData = 2 'in case no headers yet...
lrSrc = SheetLastRow(ws)
For Each c In ws.Range("A1", ws.Cells(1, Columns.Count).End(xlToLeft)).Cells
hdr = c.Value
m = Application.Match(hdr, wsData.Rows(1), 0) 'existing column match?
If IsError(m) Then
m = Application.CountA(wsData.Rows(1))
m = IIf(m = 0, 1, m + 1)
wsData.Cells(1, m).Value = hdr 'add as new column header
End If
ws.Range(c.Offset(1), ws.Cells(lrSrc, c.Column)).Copy _
wsData.Cells(lrData, m)
Next c
If abc = False Then
wsData.Range(1, wsData.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)).Value = "SheetName"
abc = True
End If
Next ws
End Sub
'return the last used row in a worksheet
Function SheetLastRow(ws As Worksheet) As Long
Dim f As Range
Set f = ws.Cells.Find("*", ws.Range("A1"), xlFormulas, xlPart, xlByRows, xlPrevious)
If Not f Is Nothing Then SheetLastRow = f.Row 'otherwise 0
End Function

Answer 1

See below for how to add the sheet name, and some other suggestions:
Option Explicit
Sub ProcessWorkbooks()
Dim f, wsData As Worksheet, wbSrc As Workbook, map As Object, strPath As String
Dim oFSO As Object, oFile As Object, nextRow As Long
On Error GoTo haveError 'ensures event/calc settings are restored
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
strPath = ChooseFolder("Select InputFile Folder... ") 'made this a new Function
If Len(strPath) = 0 Then Exit Sub
Set wsData = ThisWorkbook.Sheets("Database")
With wsData
.UsedRange.ClearContents 'clear any existing data
.Range("A1").value = "Sheet Name" 'add the sheet name header
End With
Set oFSO = CreateObject("Scripting.FileSystemObject")
For Each oFile In oFSO.getfolder(strPath).Files
If oFile.name Like "*.xls*" Then
Set wbSrc = Workbooks.Open(oFile.Path)
ImportData wbSrc, wsData
wbSrc.Close False
End If
Next oFile
With wsData.Range("A1").CurrentRegion
.Font.Size = 9
.Font.name = "Calibri"
.Borders.LineStyle = xlLineStyleNone
.EntireColumn.AutoFit
End With
haveError:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox Title:="Task Box", Prompt:="Database Created!"
End Sub
'assumes there's always a "sheet Name" header in A1 of wsData
Sub ImportData(wbIn As Workbook, wsData As Worksheet)
Dim lrData As Long, lrSrc As Long, ws As Worksheet, c As Range
Dim Process, hdr, m
Process = Array("Manila", "Cebu", "Davao", "CDO", "Bacolod") '????
For Each ws In wbIn.Worksheets
If ws.FilterMode Then ws.ShowAllData 'remove any filtering
lrData = wsData.Cells(Rows.Count, "A").End(xlUp).Row + 1 'paste row
lrSrc = SheetLastRow(ws)
wsData.Cells(lrData, "A").Resize(lrSrc - 1).value = ws.name '<<< add the sheet name....
For Each c In ws.Range("A1", ws.Cells(1, ws.Columns.Count).End(xlToLeft)).Cells
hdr = c.value
m = Application.Match(hdr, wsData.Rows(1), 0) 'existing column match?
If IsError(m) Then 'need to add this header?
m = wsData.Cells(1, Columns.Count).End(xlToLeft).Column + 1
wsData.Cells(1, m).value = hdr
End If
ws.Range(c.Offset(1), ws.Cells(lrSrc, c.Column)).Copy _
wsData.Cells(lrData, m)
Next c
Next ws
End Sub
'Ask user to select a folder. Returns empty string if none selected
Function ChooseFolder(prmpt As String) As String
Dim fldr1 As FileDialog, fldr As String
Dim iFile As String
Set fldr1 = Application.FileDialog(msoFileDialogFolderPicker)
With fldr1
.Title = prmpt
.ButtonName = "Select"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show = -1 Then ChooseFolder = .SelectedItems(1)
End With
End Function
'return the last used row in a worksheet
Function SheetLastRow(ws As Worksheet) As Long
Dim f As Range
Set f = ws.Cells.Find("*", ws.Range("A1"), xlFormulas, xlPart, xlByRows, xlPrevious)
If Not f Is Nothing Then SheetLastRow = f.Row 'otherwise 0
End Function