改进VBA代码，以将工作表复制到新工作簿并将其保存为CSV文件

Question

我有一个VBA代码，它将工作表复制到一个新的工作簿，并将工作簿保存为CSV文件。这段代码完成了它的工作，但它需要相当长的时间(~ 10 - 15分钟)来完成所有的步骤。因此，我请求帮助是否有可能优化这些代码以使其运行得更快。

需要一段时间的步骤是1)打开文件2)从工作表中复制数据3)在文件上传到sharepoint时保存文件。最后一步可能是最长的一步，因为它上传了~ 200mb到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

但是它给了我错误"Object required">

如果你有任何建议如何使这段代码更快，我将非常感激。整个代码在

下面

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