有没有更好的方法来复制工作簿和隐藏不相关的列？
有没有更好的方法来复制工作簿和隐藏不相关的列？
提问于 2019-02-22 01:51:46
我正在试着让下面的代码更高效。它目前的工作方式是我希望它，但它需要一段时间，我想知道我是否真的需要保存复制的工作簿，然后再打开它。我读到过这样做很好，但它在屏幕上放了很多杂物。
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回答 1
Stack Overflow用户
回答已采纳
发布于 2019-02-22 07:01:53
我在不测试代码的情况下提出的第一个建议是，您可以在最初的工作簿中进行所有更改，然后在最后执行SaveAs……不需要为此而关闭和重新打开。
执行SaveAs时，更改仅保存在新副本中。
这将需要对您的代码进行一些重构(只需使用一个wb而不是两个)。
然后，您可以在开始时使用application.screenupdating = false (并在结束时使用= false )，这将显著提高脚本的处理速度，因为Excel不需要在屏幕上绘制更改。
其他一些小变化..。您可以在声明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页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/54813296
复制相关文章
相似问题