Question

我正在尝试使以下代码更高效。它目前可以按我的意愿运行，但是要花一些时间，我想知道是否真的需要保存复制的工作簿才能再次打开它。我读过，这样做很好，但是它在屏幕上却杂乱无章。

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

Answer 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

有没有更好的方法来复制工作簿并隐藏不相关的列？

1 个答案: