mercmannick
05-06-2007, 09:01 AM
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
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
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
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