Solved: Shorten this VBA code

[mercmannick]

[vba]Private Sub Remove_T_L_M()
Dim r As Long
Dim Rng As Range
Dim x&
Sheets("ZF17.4").Activate
For x = Cells(Rows.Count, 2).End(xlUp).Row To 3 Step -1 '***set coumn 4 as range
With Cells(x, 3)
Select Case Left(.Value, 1)
Case "L", "T", "M" '***clear l,T,m prefix from column 3
.EntireRow.Delete
Case Else
'do nothing
End Select
End With
Next x
End Sub
Private Sub SetDate()
Dim strFileName As String
Sheets("ZF17.4").Activate
Range("B:B").Replace What:=".", Replacement:="/", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
End Sub
Private Sub Dupe_Remover()
'29/06/2005 by nhunter
Application.ScreenUpdating = False
Dim R1 As Range
Dim drow As Integer
Dim lastitem As String
Set R1 = ActiveCell
loopst:
If Trim(ActiveCell) = "" Then
GoTo procend
End If
If lastitem <> R1.Offset(drow, 0) Then
lastitem = R1.Offset(drow, 0).Value
drow = drow + 1
Else
Rows(R1.Offset(drow, 0).Row).Select
Selection.Delete Shift:=xlUp
R1.Offset(drow, 0).Select
End If
GoTo loopst
procend:
Application.ScreenUpdating = True
End Sub
Private Sub CHANGE_MRP()
Dim iLastRow As Long
Dim Rng As Range
Dim r As Long
Dim x&
Sheets("ZF17.4").Activate
For x = Cells(Rows.Count, 2).End(xlUp).Row To 4 Step -1 '***set coumn 4 as range
With Cells(x, 4)
Select Case Left(.Value, 2)
Case "B0" '***change mrp codes
.Value = "S70"
Case "B1" '***change mrp codes
.Value = "S17"
Case "S1" '***change mrp codes
.Value = "S40"
Case "I0", "I1", "I2", "I3" '***change mrp codes
.Value = "S03C"
Case "I4" '***change mrp codes
.Value = "S03E"
Case "I5" '***change mrp codes
.Value = "S03F"
Case "I6" '***change mrp codes
.Value = "S03W"
Case "I7", "I8", "I9" '***change mrp codes
.Value = "S03G"
Case Else
'do nothing
End Select
End With
Next x
End Sub
Private Sub Delete_Blank_PO()
Dim iLastRow As Long
Dim Rng As Range
Dim r As Long
Dim x&
Sheets("ZF17.4").Activate
'Per your code but shouldn't this be rows.Count, 6??
For x = Cells(Rows.Count, 2).End(xlUp).Row To 6 Step -1
'Delete rows where cells in Column F are blank
If IsEmpty(Cells(x, 6)) Then
Cells(x, 6).EntireRow.Delete
End If
Next x
End Sub
Private Sub Remove_Planned_or_purch()
Dim r As Long
Dim Rng As Range
Dim x&
Sheets("ZF17.4").Activate
For x = Cells(Rows.Count, 2).End(xlUp).Row To 6 Step -1 '***set coumn 12 as range
With Cells(x, 6)
Select Case Left(.Value, 1)
Case "p", "P" '***clear planned or purchreqs from col 6
.EntireRow.Delete
Case Else
'do nothing
End Select
End With
Next x
End Sub
Private Sub Delete_0_OPs()
Dim iLastRow As Long
Dim Rng As Range
Dim r As Long
Dim x&
Sheets("ZF17.4").Activate
'Per your code but shouldn't this be rows.Count, 6??
For x = Cells(Rows.Count, 2).End(xlUp).Row To 6 Step -1
'Delete rows where cells in Column outstanding ops are blank
If Cells(x, 12).Value = 0 Then
Cells(x, 12).EntireRow.Delete
End If
Next x
With Range("B6:M" & Cells(Rows.Count, 2).End(xlUp).Row)
.Sort Key1:=Range("F6"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
Range("F6").Activate
Call Dupe_Remover
With Range("B6:M" & Cells(Rows.Count, 2).End(xlUp).Row)
.Sort Key1:=Range("D6"), _
Order1:=xlAscending, _
Key2:=Range("B6"), _
Order1:=xlAscending, _
Header:=xlNo, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End With
End Sub
Sub zflex()
Call Remove_T_L_M
Call SetDate
Call CHANGE_MRP
Call Delete_Blank_PO
Call Remove_Planned_or_purch
Call Delete_0_OPs
End Sub
[/vba]
is there anyway of shortening this code , or making it run bit quicker at moment it taking nearly 5 mins to run through , below is list of what it is doing

Columns B replace ?.? with ?/?


On short material col c, begins with L , T or M delete all rows
Rep order column f blanks and planned orders delete all rows
On outstanding ops column L if 0 delete row
On mrp code column D: B01-B05 change to S70, begins with I0 replace with S03C, begins with I4 replace with S03E, begins with I5 replace with S03F, begins with I6 replace with S03W all remaining begins with I7*-I99 replace with S03G, begins with B15 replace with S17
Data sort rep order col F and remove duplicate entries

thanks

Merc

[Zack Barresse]

Hi there Merc,

Most of this isn't clear what you want to do. I don't really undestand the requirements you posted. I would, however, recommend you set a module variable at the top of all your code (below any Option Explicit) for a worksheet variable..

[vba]Private ws As Worksheet[/vba]

Then, your first two routines wouldn't need to select any sheets...

[vba]Private Sub Remove_T_L_M()
Dim r As Long, Rng As Range, x As Long
Set ws = Sheets("ZF17.4")
For x = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row To 3 Step -1 '***set coumn 4 as range
With ws.Cells(x, 3)
Select Case Left(.Value, 1)
Case "L", "T", "M" '***clear l,T,m prefix from column 3
.EntireRow.Delete
Case Else
'do nothing
End Select
End With
Next x
End Sub

Private Sub SetDate()
Dim strFileName As String
Set ws = Sheets("ZF17.4")
ws.Range("B:B").Replace What:=".", Replacement:="/", LookAt:=xlPart
End Sub[/vba]

The same with this routine..

[vba]Private Sub CHANGE_MRP()
Dim iLastRow As Long, Rng As Range, r As Long, x As Long
Set ws = Sheets("ZF17.4")
For x = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row To 4 Step -1 '***set coumn 4 as range
With ws.Cells(x, 4)
Select Case Left(.Value, 2)
Case "B0" '***change mrp codes
.Value = "S70"
Case "B1" '***change mrp codes
.Value = "S17"
Case "S1" '***change mrp codes
.Value = "S40"
Case "I0", "I1", "I2", "I3" '***change mrp codes
.Value = "S03C"
Case "I4" '***change mrp codes
.Value = "S03E"
Case "I5" '***change mrp codes
.Value = "S03F"
Case "I6" '***change mrp codes
.Value = "S03W"
Case "I7", "I8", "I9" '***change mrp codes
.Value = "S03G"
Case Else
'do nothing
End Select
End With
Next x
End Sub[/vba]

I'm not sure what you're trying to do with your Dupe_Remover routine. You may want to look at Ken Puls routine for removing duplicates from a specific column: http://www.excelguru.ca/node/24

Your Delete_Blank_PO routine can be changed completely...

[vba]Private Sub Delete_Blank_PO()
Set ws = Sheets("ZF17.4")
With ws.Range("F6", ws.Cells(ws.Rows.Count).End(xlUp))
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub[/vba]

You are looping quite a bit. Let's take your routine Remove_Planned_or_purch for instance. You're looping through the entire column (row 6 and down) and deleting the entire row if it starts with the letter P (lower or upper case). Instead of looping, you can insert a helper column, add a formula, filter for the formula returned (generally a boolean or IF() function) and delete the visible rows. This is basically what Ken Puls code is on the link I posted above, just apply the same type of coding.

Bottom line, taking out your loops should speed things up.

One last thing. You can toggle your application events (you did so occasionally with ScreenUpdating). I use a routine called before and after all routines...

[vba]Public Sub ToggleEvents(blnState As Boolean)
'// Written by Zack Barresse, aka firefytr
With Application
.DisplayAlerts = blnState
.EnableEvents = blnState
.ScreenUpdating = blnState
If blnState = True Then
.StatusBar = False
End If
End With
End Sub[/vba]

Since you're calling all of your routines from one 'master' routine, just change zflex routine to this ...

[vba]Sub zflex()
Call ToggleEvents(False)
Call Remove_T_L_M
Call SetDate
Call CHANGE_MRP
Call Delete_Blank_PO
Call Remove_Planned_or_purch
Call Delete_0_OPs
Call ToggleEvents(True)
End Sub[/vba]

You should see some improvement. Let us know if you need more help.

[mercmannick]

firefytr

superb thanks

Merc