Это не сайт для просмотра кода. Есть еще один, специально для этой цели, в семействе StackOverflow . Тем не менее, я просмотрел ваш код и не нашел ничего, на что я мог бы указать, чтобы сделать его медленным, в частности. Должны быть способы сделать работу быстрее, но они требуют знания ваших намерений. Кажется, у вас есть большой лист. Так что это может занять немного времени, но не достаточно, чтобы выпить кофе. Поэтому мои комментарии сосредоточены на неточности, присущей коду, что делает его склонным к взлому sh, а также склонным к неописуемому ущербу, если его потерять на неправильном листе. Я добавил комментарии.
Sub Ananplan_to_BPM()
Dim LastRow As Long
Dim LastCol As Long
Dim P As String
' Display a Dialog Box that allows to select a single file.
' The path for the file picked will be stored in fullpath variable
With Application.FileDialog(msoFileDialogFilePicker)
' Makes sure the user can select only one file - quite the opposite
.AllowMultiSelect = True
'Filter to just the following types of files to narrow down selection options
'.Filters.Add "All Files", "*.xlsx; *.xlsm; *.xls; *.xlsb; *.csv"
'Show the dialog box
.Show
'Store in fullpath variable
fullpath = .SelectedItems.Item(1)
End With
' It's a good idea to still check if the file type selected is accurate.
If InStr(fullpath, ".xls") = 0 Or InStr(fullpath, ".csv") = 0 Then
' Quit the procedure if the user didn't select the type of file we need.
Exit Sub
End If
'Open the file selected by the user
Workbooks.Open fullpath
P = InputBox("Please Enter the Version")
Application.ScreenUpdating = False
With ActiveWorkbook
' There isn't a single reference to the ActiveWorkbook
' in the entire 'With' bracket.
' Create a link to the 'With' object by a leading period.
' Example:-
' With .Worksheets(1) ' linked to ActiveWorkbook
' ' below, both cells and Rows.Count of Worksheets(1)
' LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
' End With
' which sheet are you working on here?
LastRow = Cells(Rows.Count, 2).End(xlUp).Row
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
Columns(17).NumberFormat = "0"
Columns(19).NumberFormat = "0"
Columns("I").Copy
Columns("I").Insert Shift:=xlToRight
'Range("AE2").Value = P
'Range("AE2", "AE" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Columns("AE").Copy
Columns("P").PasteSpecial xlPasteValues
' You didn't activate any sheet
ActiveSheet.Range("A:A,AE:AG").EntireColumn.Delete
' everything you do above or below this line
'' is done to the ActiveSheet
Columns("AC").Replace What:="#", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Columns("AC").Replace What:="OUT", Replacement:=P, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
' This should probably be done using a cell format.
' If you need rounded values in later calculations do
' the rounding in later calculations, not in the original data.
Range("AD2").Formula = "=Round(Q2,2)"
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
Range("Q2").PasteSpecial xlPasteValues
Range("AD2").Formula = "=Round(S2,2)"
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
Range("S2").PasteSpecial xlPasteValues
Range("AD2").Formula = "=(Q2*-1)"
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
Range("Q2").PasteSpecial xlPasteValues
Columns("AD:AD").EntireColumn.Delete
End With
With ActiveSheet.Range("A:AC")
' This method will throw an error if there are no visible cells
' why not suppress the display of zero with a CellFormat?
.AutoFilter Field:=17, Criteria1:="0"
.AutoFilter Field:=19, Criteria1:="0"
.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
.AutoFilter Field:=17, Criteria1:="0"
.Range("Q2:R" & LastRow).SpecialCells(xlCellTypeVisible).Clear
.AutoFilter
.AutoFilter Field:=19, Criteria1:="0"
.Range("S2:T" & LastRow).SpecialCells(xlCellTypeVisible).Clear
.AutoFilter
'.Range("C2").AutoFill .Range("C2:C" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
ThisWorkbook.Sheets("Tool").Range("A20:AC20").Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
' you are still working on the undefined ActiveSheet
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Rows("1").SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
'ActiveWorkbook.Save
'ActiveWorkbook.Close
MsgBox "Done With Formatting"
End Sub