Есть ли лучший способ скопировать рабочую книгу и скрыть ненужные столбцы?

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 в конце ... Нет необходимости закрывать и открывать для этой цели.

Когда вы делаете 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