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

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

CodePudding user response：

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