Оптимизация кода

[ViktorG]

Так как только начинаю работать с VBA то
прошу помочь оптимизировать данный код:

Sub Proverka()
Dim ss, zz As Range
oWin = Mid(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, "\") + 1)
NewFN = Application.GetOpenFilename(Title:= "Пожалуйста выберите файл")
Workbooks.OpenText Filename:=NewFN
newwn = Mid(NewFN, InStrRev(NewFN, "\") + 1)
Windows(newwn).Activate
Columns("A:V").Select
Selection.Copy
Windows(oWin).Activate
Worksheets.Add
Range("A1").Select
ActiveSheet.Paste
Selection.UnMerge
Worksheets(2).Name = "Их"
Worksheets(1).Name = "Наш"
Worksheets("Наш").Activate

1:
nRow = 1 ' Или Ваше значение
i = 1
Application.ScreenUpdating = False
With ActiveSheet.Range("a1:F1")
Set c = .Find("FM", LookIn:=xlValues)
Set d = .Find("IM", LookIn:=xlValues)
Set e = .Find("OT", LookIn:=xlValues)
If Not c Is Nothing Then
FMAdres = c.Address
FMColumnName = Mid(c.Address, 2, (InStr(2, c.Address, "$") - 2))
End If
If Not d Is Nothing Then
IMAdres = d.Address: IMColumnName = Mid(c.Address, 2, (InStr(2, c.Address, "$") - 2))
End If
If Not e Is Nothing Then
OTAdres = e.Address: OTColumnName = Mid(c.Address, 2, (InStr(2, c.Address, "$") - 2))
End If
' MsgBox (FMAdres & vbCr & FMColumnName & vbCr & IMAdres & vbCr & OTAdres)
End With

If FMColumnName = "B" Then
For Each ss In ActiveWorkbook.ActiveSheet.UsedRang e.Columns(5).Cells
ss.Value = Replace(ss, "д. ", "")
ss.Value = Replace(ss, "с. ", "")
ss.Value = Replace(ss, "п. ", "")
Next
End If
While ActiveSheet.Cells(nRow, 2) <> ""
If FMColumnName = "B" Then
Range("W" & i).Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-21],"" "",RC[-20],"" "",RC[-19],"" "",RC[-18])"
Range("X" & i).Select
Range("X" & i).Value = Range("M" & i).Value
ElseIf FMColumnName = "C" Then
Range("CE" & i).Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-80],"" "",RC[-79],"" "",RC[-78],"" "",RC[-74])"
Range("CF" & i).Select
ActiveCell.FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-1],Наш!R2C23:R1907C24,2,0)),0,VLOOKUP (RC[-1],Наш!R2C23:R1907C24,2,0))"
If i > 1 Then
Range("AD" & i).Select
Range("AD" & i).Value = Range("CF" & i).Value
End If
End If
i = i + 1
nRow = nRow + 1
Wend
Application.ScreenUpdating = True
If ActiveSheet.Name = "Их" Then
Application.ScreenUpdating = 0
Windows(newwn).Activate: Worksheets.Add
Windows(oWin).Activate
nRow = 2: i = 2
Worksheets("наш").Activate
While ActiveSheet.Cells(nRow, 2) <> ""
Range("Y" & i).Select
ActiveCell.FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-2],Их!RC[58]:R[3595]C[58],1,0)),0,VLOOKUP(RC[-2],Их!RC[58]:R[3595]C[58],1,0))"
i = i + 1: nRow = nRow + 1
Wend
m = 1
For Each zz In ActiveWorkbook.ActiveSheet.UsedRang e.Columns(25).Cells
If zz.Value = 0 Then
Workbooks("едк").Worksheets(1).Rang e("A" & m).Value = "=[" & oWin & "]" & "Наш!R" & m & "C23"
Workbooks("едк").Worksheets(1).Rang e("A" & m).Value = Workbooks("едк").Worksheets(1).Rang e("A" & m).Value
m = m + 1
End If
Next
Application.DisplayAlerts = False
Worksheets("наш").Delete
Application.DisplayAlerts = True
Worksheets("Их").Activate
Range("CE:CF").ClearContents
Windows(newwn).Activate
ActiveWindow.DisplayWorkbookTabs = True
ActiveWindow.TabRatio = 0.6
' LastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
' For r = LastRow To 1 Step -1
' If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
' Next r
Application.ScreenUpdating = True
MsgBox ("Готово")
Exit Sub
End If

Worksheets("Их").Activate
GoTo 1

MsgBox ("Готово")

End Sub

[EducatedFool]

оптимизировал кусок кода:
(не полностью - но уже намного лучше, чем было)

    Application.ScreenUpdating = False
    Dim FMColumn%, IMColumn%, OTColumn%
    On Error Resume Next
    With Range("A1:F1")
        FMColumn% = .Find("FM").Column
        IMColumn% = .Find("IM").Column
        OTColumn% = .Find("OT").Column
    End With

    If FMColumn% = 2 Then
        With ActiveSheet.UsedRange.Columns(5)
            .Replace "д. ", ""
            .Replace "с. ", ""
            .Replace "п. ", ""
        End With
    End If

    While Cells(nRow, 2) <> ""
        Select Case FMColumn%
            Case 2
                Range("W" & i).FormulaR1C1 = "=CONCATENATE(RC[-21],"" "",RC[-20],"" "",RC[-19],"" "",RC[-18])"
                Range("X" & i).Value = Range("M" & i).Value
            Case 3
                Range("CE" & i).FormulaR1C1 = "=CONCATENATE(RC[-80],"" "",RC[-79],"" "",RC[-78],"" "",RC[-74])"
                Range("CF" & i).FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-1],Наш!R2C23:R1907C24,2,0)),0,VLOOKUP (RC[-1],Наш!R2C23:R1907C24,2,0))"
                If i > 1 Then Range("AD" & i) = Range("CF" & i).Value
        End Select
        i = i + 1: nRow = nRow + 1
    Wend

[ViktorG]

Case 3
Range("CE" & i).FormulaR1C1 = "=CONCATENATE(RC[-80],"" "",RC[-79],"" "",RC[-78],"" "",RC[-74])"
Range("CF" & i).FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-1],Наш!R2C23:R1907C24,2,0)),0,VLOOKUP (RC[-1],Наш!R2C23:R1907C24,2,0))"


(Range("CF" & i).FormulaR1C1 =) почему то не работает. Не заполняется формула.

[EducatedFool]

почему то не работает. Не заполняется формула.

уберите пробел после VLOOKUP

[ViktorG]

Большое спасибо