Sub SOTR()   
Application.ShowWindowsInTaskbar = False   
Application.ScreenUpdating = False   
Application.Calculation = xlCalculationManual   
   
Dim MyPath, MyName As String, Str As Integer, Wb As Workbook, rngx As Range, ix As Long, rngy As Range, iy As Long   
   
Sheets(1).UsedRange.Clear   
Sheets(2).UsedRange.Clear   
   
MyPath = "\\comp7\Апельсины\"   
MyName = "образец.xls"   
Str = "153"   
   
With Sheets(1)   
    Set Wb = Workbooks.Open(Filename:=MyPath & MyName, Password:=Str)   
    ActiveSheet.Range("A:M").Copy .Cells(1, 1)   
    Wb.Close SaveChanges:=False   
    .Range("D:F", "H:L").Delete   
    .UsedRange.UnMerge   
    LastRow = .UsedRange.Row - 1 + .UsedRange.Rows.Count   
    For r = LastRow To 1 Step -1   
    If Cells(r, 2) = 0 Then Rows(r).Delete   
    Next r   
End With   
           
   
   Sheets(1).UsedRange.Copy   
   Sheets(2).Select   
   Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _   
        SkipBlanks:=False, Transpose:=False   
   ActiveSheet.Paste   
   Application.CutCopyMode = False   
   
           
           
Set rngx = Intersect(Range("B:B"), Sheets(1).UsedRange)   
For ix = rngx.Count To 1 Step -1   
Select Case rngx.Item(ix).Interior.ColorIndex   
Case 3, 7, 9, 13, 18, 21, 22, 26, 29, 30, 38, 39, 45, 46, 53, 54   
rngx.Item(ix).EntireRow.Delete   
End Select   
Next   
   
   
With Sheets(1)   
    Range("A:A,C:C,C:C,D:D").Select   
    With Selection   
        .HorizontalAlignment = xlCenter   
        .VerticalAlignment = xlCenter   
        .Orientation = 0   
        .AddIndent = False   
        .IndentLevel = 0   
        .ShrinkToFit = False   
        .ReadingOrder = xlContext   
        .MergeCells = False   
    End With   
    Range("B:B").Select   
        With Selection   
        .VerticalAlignment = xlCenter   
        .WrapText = False   
        .Orientation = 0   
        .AddIndent = False   
        .IndentLevel = 0   
        .ShrinkToFit = False   
        .ReadingOrder = xlContext   
        .MergeCells = False   
    End With   
End With   
   
Application.Calculation = xlCalculationAutomatic   
Application.ScreenUpdating = True   
Application.ShowWindowsInTaskbar = True   
End Sub