改進 VBA 代碼將工作表復制到新工作簿並保存為 CSV 文件

Question

我有一個 VBA 代碼，它將工作表復制到新的工作簿並將工作簿保存為 CSV 文件。 這段代碼可以完成工作，但完成所有步驟需要相當長的時間（約 10 - 15 分鍾）。 所以，我尋求幫助是否可以優化這些代碼以更快地運行它。

需要一段時間的步驟是 1) 打開文件 2) 從工作表中復制數據 3) 在文件上傳到 sharepoint 時保存文件。最后一步可能是最長的一步，因為它將 ~200 mb 上傳到 sharepoint 文件夾

打開的文件很重（~250mb）並且包含大量數據，所以在這里我相信什么都做不了

為了復制 innfo，我嘗試使用

closedbook.Sheets("new rates").Range("A:AW").Value2 = newbook.Sheets(1).Range("A1").Value2

代替

closedbook.Sheets("new rates").Range("A:AW").Copy
newbook.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues

但它給了我錯誤“需要對象”

如果您對如何使此代碼更快有任何建議，我將不勝感激。 整個代碼如下

Sub CSVformWorksheet()
Dim year As Variant
Dim filetopen As Variant
Dim diaFile As FileDialog
year = Format(Now(), "yyyy")
Set diaFile = Application.FileDialog(msoFileDialogFilePicker)
    With diaFile
    .AllowMultiSelect = False
    .InitialFileName = "https://website.sharepoint.com/sites/folders/Shared Documents/Fodler/AnotherFolder/" & year & "/"
    .Show
    End With
filetopen = diaFile.SelectedItems(1)
    If filetopen <> False Then
    With Application
    .ScreenUpdating = False
    .AskToUpdateLinks = False
    .DisplayClipboardWindow = False
    .DisplayAlerts = False
    .EnableAnimations = Flase
    .Calculation = xlCalculationManual
        Set closedbook = Workbooks.Open(filetopen)
        Set newbook = Workbooks.Add
        closedbook.Sheets("new rates").Range("A:AW").Copy
        newbook.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
        newbook.SaveAs Filename:="https://website.sharepoint.com/sites/Folder/Shared Documents/Folder/Another Folder/18/Calculators/2021/Folder/work/Total_RF_CSV.csv", FileFormat:=xlCSV, Local:=True
        closedbook.Close SaveChanges:=False
        newbook.Close SaveChanges:=False
    .ScreenUpdating = True
    .AskToUpdateLinks = True
    .DisplayClipboardWindow = True
    .DisplayAlerts = True
    .EnableAnimations = True
    .Calculation = xlCalculationAutomatic
    End With
    ThisWorkbook.Connections("Query - Total_RF CSV").Refresh
    MsgBox "File was saved to the folder | Data refreshed", vbInformation
    End If
End Sub

Answer 1

導出工作表到 CSV

• 仔細調整常量部分中的值（路徑），因為可能存在一些拼寫錯誤（在您的帖子和/或此處）。

• 由於您只需要值（ CSV ），所謂的copying by assignment是最快的：

   dfCell.Resize(srg.Rows.Count, srg.Columns.Count).Value = srg.Value

Option Explicit

Sub ExportWorksheetToCSV()
    Const ProcName As String = "ExportWorksheetToCSV"
    Const ProcTitle As String = "Export Worksheet to CSV"
    
    ' Source
    Const sYearFormat As String = "YYYY"
    Const sFolderPathLeft As String = "https://website.sharepoint.com/sites/" _
        & "Folder/Shared Documents/" _
        & "Folder/Another Folder/"
    Const sName As String = "New Rates"
    Const sCols As String = "A:AW"
    ' Destination
    Const dFilePath As String = "https://website.sharepoint.com/sites/" _
        & "Folder/Shared Documents/" _
        & "Folder/Another Folder/18/Calculators/2021/" _
        & "Folder/work/Total_RF_CSV.csv"
    Const dFirst As String = "A1"
    ' ThisWorkbook
    Const qName As String = "Query - Total_RF CSV"
 
    Dim MsgString As String
    Dim WasSuccessful As Boolean
    
    On Error GoTo ClearError
    
    Dim sYear As String: sYear = Format(Now, sYearFormat)
    Dim sFolderPath As String: sFolderPath = sFolderPathLeft & sYear & "/"
 
    Dim sFilePath As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .InitialFileName = sFolderPath
        If .Show Then
            sFilePath = .SelectedItems(1)
        Else
            MsgBox "Dialog canceled.", vbExclamation, ProcTitle
            Exit Sub
        End If
    End With
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook: Set swb = Workbooks.Open(sFilePath)
    Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
    Dim srg As Range
    With sws.Range(sCols)
        Dim sCell As Range
        Set sCell = .Find("*", xlFormulas, , , xlByRows, xlPrevious)
        Set srg = .Resize(sCell.Row - .Row + 1)
    End With
    
    Dim dwb As Workbook: Set dwb = Workbooks.Add
    Dim dws As Worksheet: Set dws = dwb.Worksheets(1)
    Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
    Dim drg As Range: Set drg = dfCell.Resize(srg.Rows.Count, srg.Columns.Count)
    drg.Value = srg.Value
    Application.DisplayAlerts = False ' overwrite without confirmation
    dwb.SaveAs Filename:=dFilePath, FileFormat:=xlCSV, Local:=True
    Application.DisplayAlerts = True
    dwb.Close
    
    swb.Close False
    
    With ThisWorkbook
        .Connections(qName).Refresh
        '.Save
    End With
    
    WasSuccessful = True
    
ProcExit:
    If Not Application.DisplayAlerts Then
        Application.DisplayAlerts = True
    End If
    If Not Application.ScreenUpdating Then
        Application.ScreenUpdating = True
    End If
    
    If WasSuccessful Then
        MsgBox "Worksheet '" & sName & "' exported.", vbInformation, ProcTitle
    Else
        MsgBox "Worksheet '" & sName & "' could not be exported." _
            & MsgString, vbCritical, ProcTitle
    End If
    
    Exit Sub
ClearError:
    MsgString = vbLf & vbLf & "Procedure '" & ProcName _
        & "': Unexpected Error!" & vbLf _
        & "Run-time error '" & Err.Number & "':" & vbLf & Err.Description
    Resume ProcExit
End Sub

• 如果可以選擇復制完整的工作表，請將Dim srg As Range到dwb.Close的行（19 行）替換為以下內容：

sws.Copy
With ActiveWorkbook
    Application.DisplayAlerts = False ' overwrite without confirmation
    .SaveAs Filename:=dFilePath, FileFormat:=xlCSV, Local:=True
    Application.DisplayAlerts = True
    .Close
End With