Как уменьшить время работы макроса? - VBA - Ответ 4673043

Option Explicit
 
Sub цены()
'    Dim i As Integer
'    Dim j As Integer
'    Dim u As Integer
'    Dim FinalRow As Long
'    Dim oRange As Range
'    Dim x As Integer
'    Dim y As Integer
'    Dim l As Integer
    Dim Rng As Object
    Dim fname$, d&
    Dim fr As Range, cr As Range, wb As Workbook
 
    On Error Resume Next
    Set Rng = Application.InputBox(Prompt:="Укажите книгу(лист) для поиска", Type:=8)
    If Rng Is Nothing Then Exit Sub
    On Error GoTo 0
    Set Rng = Rng.Parent
    MsgBox Rng.Name
 
    fname = InputBox("Введите новое название шаблона")
    Workbooks("Шаблон_1.xls").Worksheets("Лист1").copy
    Set wb = ActiveWorkbook
    wb.SaveAs Filename:=fname, FileFormat:=xlCSV, local:=True
    Dim sdat As Date
    Dim Today As Date
1
    On Error Resume Next
    sdat = InputBox("Введите дату начала закупочной цены")
    If sdat = CDate(0) Then Exit Sub
    On Error GoTo 0
    Today = Date
    d = DateDiff("d", Today, sdat)
    If d <= 0 Then MsgBox ("Дата начала закупочной цены должна быть больше системной даты, проверьте введенные Вами данные"): GoTo 1
 
    With Rng
        Set fr = .UsedRange.Find("Код товара (штрих код)", , xlValues, xlWhole)
        If Not fr Is Nothing Then
            Set cr = Range(.Cells(fr.Row + 1, fr.Column), .Cells(fr.Row + 1, fr.Column).End(xlDown))
            cr.copy Destination:=wb.Sheets(1).Range("e2")
            wb.Sheets(1).Range("n2").Resize(cr.Rows.Count) = sdat
        End If
 
        Set fr = .UsedRange.Find("Цена за единицу без НДС", , xlValues, xlWhole)
        If Not fr Is Nothing Then
            Range(.Cells(fr.Row + 1, fr.Column), .Cells(fr.Row + 1, fr.Column).End(xlDown)).copy Destination:=wb.Sheets(1).Range("m2")
        End If
 
        '    For b = 1 To 50
        '        For v = 1 To 50
        '            If StrComp(Rng.Cells(b, v), "Поставщик") = 0 Then
        '                pos = Rng.Cells(b + 1, v + 1)
        '            End If
        '        Next
        '    Next
        '    For p = 1 To 30000
        '        If StrComp(Workbooks("Шаблон_1.xls").Worksheets("Коды поставщиков").Cells(p, 1), pos) = 0 Then
        '            pos = Workbooks("Шаблон_1.xls").Worksheets("Коды поставщиков").Cells(p, 2)
        '        End If
        '    Next
        '
        '    For e = 2 To 999
        '        If ActiveWorkbook.ActiveSheet.Cells(e, 5) <> 0 Then
        '            ActiveWorkbook.ActiveSheet.Cells(e, 9) = pos
        '        End If
        '    Next
 
        For Each cr In wb.Sheets(1).Cells(1, 1).CurrentRegion.Cells
            If Not .UsedRange.Find(Left(cr, 7), , xlValues, xlWhole) Is Nothing Then
                cr.Offset(, 1) = 1
            End If
        Next
 
    End With
 
End Sub