Vader

HELP with optimization and compacting!!!


Sub Vader_Extract_Tel_Bills()
Application.ScreenUpdating = False
Range("C:C,D,E:E,F:F,G:G").Delete Shift:=xlToLeft
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Dim rng As Range
Dim Mime1, Mime2, Mime3, Mime4 As String
Mime1 = "/200"
Mime2 = "Vkupno:"
Mime3 = "ddv"
Mime4 = "mesecna"

Do
Set rng = ActiveSheet.Range("A:A").Find(Mime1)
If rng Is Nothing Then
Exit Do
Else
Rows(rng.Row).Delete
End If
Loop

Do
Set rng = ActiveSheet.Range("A:A").Find(Mime2)
If rng Is Nothing Then
Exit Do
Else
Rows(rng.Row).Delete
End If
Loop

Do
Set rng = ActiveSheet.Range("A:A").Find(Mime3)
If rng Is Nothing Then
Exit Do
Else
Rows(rng.Row).Delete
End If
Loop

Do
Set rng = ActiveSheet.Range("A:A").Find(Mime4)
If rng Is Nothing Then
Exit Do
Else
Rows(rng.Row).Delete
End If
Loop

Rows("1:2").Delete Shift:=xlUp

Dim X As Long
Dim LastRow As Long
Dim Evens As Range
With ActiveSheet
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For X = 2 To LastRow Step 2
.Range("A" & X & ":J" & X).Copy .Cells(X - 1, "C")
.Range("A" & X & ":J" & X).Clear
Next
End With

Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Columns("C:C").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=":", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Range("A:A,C:C").Delete Shift:=xlToLeft
Application.ScreenUpdating = True
End Sub