我正在尝试使以下代码更高效。它目前可以按我的意愿运行,但是要花一些时间,我想知道是否真的需要保存复制的工作簿才能再次打开它。我读过,这样做很好,但是它在屏幕上却杂乱无章。
Dim ws1 As Worksheet, ws2 As Worksheet
Dim wb1 As Workbook, wb2 As Workbook, NewBook As String
Dim newValue As Variant, i As Long, n As Long
newValue = InputBox("Statement for input box")
folderPath = Application.ActiveWorkbook.path
Set wb1 = ActiveWorkbook
Worksheets(Array("Sheet names")).Copy
With ActiveWorkbook
NewBook = folderPath & "\" & newValue & ".xlsm"
.SaveAs Filename:=NewBook, FileFormat:=xlOpenXMLWorkbookMacroEnabled
.Close SaveChanges:=True
Set wb2 = Workbooks.Open(NewBook)
With wb2
Set ws1 = wb2.Worksheets("Sheet1")
With ws1
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
LastRow = .Cells(.Rows.Count, lastColumn).End(xlUp).Row
stopColumn = lastColumn - 12
i = 4
While i <= stopColumn
n = i + 1
ColumnName = ws1.Cells(2, i).Value
If ColumnName <> newValue Then
ws1.Cells(2, i).EntireColumn.Hidden = True
ws1.Cells(2, n).EntireColumn.Hidden = True
End If
ColumnName = ""
i = i + 2
Wend
End With
End With
End With
答案 0 :(得分:1)
在不测试您的代码的情况下,我会提出的第一个建议是,您可以在初始工作簿中进行所有更改,然后在最后进行SaveAs
...无需为此目的而关闭并重新打开。< / p>
执行SaveAs
时,更改仅保存在新副本中。
这将需要对代码进行一些重构(只需使用一个wb而不是两个)。
然后,您可以在开始时使用application.screenupdating = false
(在末尾使用= {false),这将显着提高脚本的处理速度,因为Excel无需在屏幕上绘制更改。 / p>
其他一些小的更改...您可以在声明wb之后立即设置wb,然后将变量重用于:
folderPath = wb.path
或
With wb
.....
'instead of With ActiveWorkbook
希望这会有所帮助。
编辑: 添加了改进的版本-希望如此。
Option Explicit 'Is always advisable to use Option Explicit, it will identify any variables that haven't been declared or possible mispelling in some
Sub test()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
'.Calculation = xlCalculationManual 'If you have lots of formulas in your spreadsheet, deactivating this could help as well
End With
'Uncomment the below when you are confident your code is working as intended
'On Error GoTo errHandler 'if any error, we need to reactivate the above
'Declaring the variables - i would always start with the workbook, as you can declare and initialize immediately (if known)
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim newValue As Variant: newValue = InputBox("Statement for input box")
Dim newBook As String: newBook = wb.Path & "\" & newValue & ".xlsm"
Dim i As Long, lastColumn As Long, lastRow As Long, stopColumn As Long
With wb
With ws
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastRow = .Cells(.Rows.Count, lastColumn).End(xlUp).row
stopColumn = lastColumn - 12
For i = 4 To stopColumn Step 2
If .Cells(2, i).Value <> newValue Then
.Range(.Cells(2, i), .Cells(2, i + 1)).EntireColumn.Hidden = True
End If
Next i
End With 'ws
.SaveAs Filename:=newBook, FileFormat:=xlOpenXMLWorkbookMacroEnabled
.Close SaveChanges:=True
End With 'wb
GoTo finish 'If no errors, skip the errHandler
errHandler:
MsgBox "An error occured, please step through code or comment the 'On Error GoTo errHandler"
finish:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
'.Calculation = xlCalculationAutomatic
End With
End Sub