使用“范圍”設置列值會出錯

Question

下面的代碼從多個工作表復制數據並合並到數據庫（數據庫工作表）中。 我正在嘗試在數據庫工作表的最后一個未使用的列中添加一個新列，該列給出每行中工作表的名稱，數據是從 header 列作為“工作表名稱”復制而來的。 問題是，我試圖通過使用wsData.Range(1, wsData.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)).Value = "SheetName" ，但不幸的是，它給出了一個錯誤。

該程序目前需要 6 分鍾來處理大約 25,000 行，那么有沒有辦法讓它更快？

我對 VBA 不太熟悉，我從另一個堆棧溢出問題中收到了以下代碼。 下面是我的代碼。 任何幫助將不勝感激。

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

有關如何添加工作表名稱以及其他一些建議，請參見下文：

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