Code to Sort, Replace and Count results

[mercmannick]

help to write this code ............

Hi All

wonder if it is possible to have code to do this


below is a s/sheet i have and i go through 6 diffrent ones each day all the same layout

1 to sort by col o and delete the rows with "cnf"
2 data sort by col B and delete any rows beginning with 55*********
3 replace the . with a / in col e
4 data sort col e
5 to output in a msgbox the following
(all from todays date)
6 count of rows upto 1 week from today
7 count of rows upto 1 - 2 weeks from today
8 count of rows upto 2 - 3 weeks late from today
and the remaining from 3 weeks on to end of list


Regards

Merc

Sample of Sheet below

[mercmannick]

:help


Thanks

Merc

[chandansify]

help to write this code ............

Hi All

wonder if it is possible to have code to do this


below is a s/sheet i have and i go through 6 diffrent ones each day all the same layout

1 to sort by col o and delete the rows with "cnf"
2 data sort by col B and delete any rows beginning with 55*********
3 replace the . with a / in col e
4 data sort col e
5 to output in a msgbox the following
(all from todays date)
6 count of rows upto 1 week from today
7 count of rows upto 1 - 2 weeks from today
8 count of rows upto 2 - 3 weeks late from today
and the remaining from 3 weeks on to end of list


Regards

Merc

Sample of Sheet below
Dear,

I have created a Macro Procedure.

Just Copy Paste it VBE and Run


Sub ToughMacro()
' Procedure : ToughMacro
' DateTime : 7/8/2005 13:11
' Author : Chandan Banga
' Purpose : Customised Requirements
Dim iRow As Double
Dim iSheetCount As Integer
Dim iCountCurrentWeek As Double
Dim iCount1to2Week As Double
Dim iCount2to3Week As Double
Dim iCount3toAll As Double
Rows("8:8").Select 'Selecting Start Row
Range(Selection, Selection.End(xlDown)).Select 'Selecting Upto n Row
Selection.Sort Key1:=Range("O8"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom 'Sorting Column 0
iRow = 8
While Cells(iRow, 2).Value <> ""
If Cells(iRow, Asc("O") - 64).Value = "CNF" Then
Rows(iRow).Delete
Else
iRow = iRow + 1
End If
Wend
Rows("8:8").Select 'Selecting Start Row
Range(Selection, Selection.End(xlDown)).Select 'Selecting Upto n Row
Selection.Sort Key1:=Range("B8"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom 'Sorting Column 0
iRow = 8
While Cells(iRow, 2).Value <> ""
If Cells(iRow, Asc("B") - 64).Value Like "55*" Then
Rows(iRow).Delete
Else
iRow = iRow + 1
End If
Wend
iRow = 8
While Cells(iRow, 2).Value <> ""
Cells(iRow, Asc("E") - 64).Value = Replace(Cells(iRow, Asc("E") - 64).Value, ".", "/")
iRow = iRow + 1
Wend
Rows("8:8").Select 'Selecting Start Row
Range(Selection, Selection.End(xlDown)).Select 'Selecting Upto n Row
Selection.Sort Key1:=Range("E8"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom 'Sorting Column 0
iRow = 8
While Cells(iRow, Asc("E") - 64).Value <> ""
If CDate(Cells(iRow, Asc("E") - 64).Value) >= Date And CDate(Cells(iRow, Asc("E") - 64).Value) <= (Date + 6) Then
iCountCurrentWeek = iCountCurrentWeek + 1
ElseIf CDate(Cells(iRow, Asc("E") - 64).Value) >= (Date + 7) And CDate(Cells(iRow, Asc("E") - 64).Value) <= Date + 13 Then
iCount1to2Week = iCount1to2Week + 1
ElseIf CDate(Cells(iRow, Asc("E") - 64).Value) >= (Date + 14) And CDate(Cells(iRow, Asc("E") - 64).Value) <= Date + 20 Then
iCount2to3Week = iCount2to3Week + 1
ElseIf CDate(Cells(iRow, Asc("E") - 64).Value) >= (Date + 21) Then
iCount3toAll = iCount3toAll + 1
End If
iRow = iRow + 1
Wend
MsgBox ("Total Count " & vbCrLf & _
"Current Week : " & iCountCurrentWeek & vbCrLf & _
"Next 1 - 2 Week : " & iCount1to2Week & vbCrLf & _
"Next 2 - 3 Week : " & iCount2to3Week & vbCrLf & _
"Next 3 weeks and later : " & iCount3toAll)
End Sub




It is working on the excel sheet what u have provided.


Bye..

[mdmackillop]

Question title revised to reflect content.

[Bob Phillips]

I have created a Macro Procedure.

Just Copy Paste it VBE and Run

It is working on the excel sheet what u have provided.

Some thoughts on this.

Firstly, the sorts are not needed. I think mercmannick just did them to help with the manula process. AUtomating it can remove that overhead.

Second, deleting rows should always be done bottom up, otherwise your pointers get messed.

You loop through the data many times doing separate processes. They can all be combined into one loop.

And finally, very problemmatical, is your date processing. VBA uses US style dates regardless of language settings. So when you used the code


Cells(iRow, Asc("E") - 64).Value = Replace(Cells(iRow, Asc("E") - 64).Value, ".", "/")

dates such as 10/11/2005 was getting flipped to 11/10/2005. I was getting a different result on a second run, and the the original results on a third run, and so on. Very confusing. It might be okay with US spreadsheets but I notice that mercmannick has UK style dates.

PS - it deletes rows with CNF in column O. I notice some PCNF, should these be deleted.


Option Explicit

Sub ToughMacro()
' Procedure : ToughMacro
' DateTime : 7/8/2005 13:11
' Author : Chandan Banga
' Purpose : Customised Requirements
Dim iRow As Long
Dim iLastRow As Long
Dim iSheetCount As Long
Dim iCountCurrentWeek As Long
Dim iCount1to2Week As Long
Dim iCount2to3Week As Long
Dim iCount3toAll As Long
Dim cNotIncluded As Long
Dim rngToSort As Range
iLastRow = Range("B8").End(xlDown).Row
For iRow = iLastRow To 8 Step -1
If Cells(iRow, Asc("O") - 64).Value = "CNF" Or _
Cells(iRow, "B").Value Like "55*" Then
Rows(iRow).Delete
Else
With Cells(iRow, "E")
.Value = DateValue(Replace(.Value, ".", "/"))
If .Value >= Date And .Value <= (Date + 6) Then
iCountCurrentWeek = iCountCurrentWeek + 1
ElseIf .Value >= (Date + 7) And .Value <= Date + 13 Then
iCount1to2Week = iCount1to2Week + 1
ElseIf .Value >= (Date + 14) And .Value <= Date + 20 Then
iCount2to3Week = iCount2to3Week + 1
ElseIf .Value >= (Date + 21) Then
iCount3toAll = iCount3toAll + 1
Else
cNotIncluded = cNotIncluded + 1
End If
End With
End If
Next iRow
MsgBox "Total Count " & vbCrLf & _
"========================" & vbNewLine & _
"Current Week : " & iCountCurrentWeek & vbCrLf & _
"Next 1 - 2 Week : " & iCount1to2Week & vbCrLf & _
"Next 2 - 3 Week : " & iCount2to3Week & vbCrLf & _
"Next 3 weeks and later : " & iCount3toAll & vbNewLine & _
"Not counted : " & cNotIncluded, , "Weekly Counts"
End Sub

[chandansify]

Some thoughts on this.

Firstly, the sorts are not needed. I think mercmannick just did them to help with the manula process. AUtomating it can remove that overhead.

Second, deleting rows should always be done bottom up, otherwise your pointers get messed.

You loop through the data many times doing separate processes. They can all be combined into one loop.

And finally, very problemmatical, is your date processing. VBA uses US style dates regardless of language settings. So when you used the code

Cells(iRow, Asc("E") - 64).Value = Replace(Cells(iRow, Asc("E") - 64).Value, ".", "/")

dates such as 10/11/2005 was getting flipped to 11/10/2005. I was getting a different result on a second run, and the the original results on a third run, and so on. Very confusing. It might be okay with US spreadsheets but I notice that mercmannick has UK style dates.

PS - it deletes rows with CNF in column O. I notice some PCNF, should these be deleted.


Option Explicit

Sub ToughMacro()
' Procedure : ToughMacro
' DateTime : 7/8/2005 13:11
' Author : Chandan Banga
' Purpose : Customised Requirements
Dim iRow As Long
Dim iLastRow As Long
Dim iSheetCount As Long
Dim iCountCurrentWeek As Long
Dim iCount1to2Week As Long
Dim iCount2to3Week As Long
Dim iCount3toAll As Long
Dim cNotIncluded As Long
Dim rngToSort As Range
iLastRow = Range("B8").End(xlDown).Row
For iRow = iLastRow To 8 Step -1
If Cells(iRow, Asc("O") - 64).Value = "CNF" Or _
Cells(iRow, "B").Value Like "55*" Then
Rows(iRow).Delete
Else
With Cells(iRow, "E")
.Value = DateValue(Replace(.Value, ".", "/"))
If .Value >= Date And .Value <= (Date + 6) Then
iCountCurrentWeek = iCountCurrentWeek + 1
ElseIf .Value >= (Date + 7) And .Value <= Date + 13 Then
iCount1to2Week = iCount1to2Week + 1
ElseIf .Value >= (Date + 14) And .Value <= Date + 20 Then
iCount2to3Week = iCount2to3Week + 1
ElseIf .Value >= (Date + 21) Then
iCount3toAll = iCount3toAll + 1
Else
cNotIncluded = cNotIncluded + 1
End If
End With
End If
Next iRow
MsgBox "Total Count " & vbCrLf & _
"========================" & vbNewLine & _
"Current Week : " & iCountCurrentWeek & vbCrLf & _
"Next 1 - 2 Week : " & iCount1to2Week & vbCrLf & _
"Next 2 - 3 Week : " & iCount2to3Week & vbCrLf & _
"Next 3 weeks and later : " & iCount3toAll & vbNewLine & _
"Not counted : " & cNotIncluded, , "Weekly Counts"
End Sub




Right Master.

I think I need some extra training on logic building. You are right we can easily delete extra loops here.


Thanks for the correction.

I found that my logical building knowledge is very low. I need to do some homework on it.


:bow:

[Bob Phillips]

I found that my logical building knowledge is very low. I need to do some homework on it.

Maybe, but your code is very structured and easy to follow :thumb

[mercmannick]

Guys an Gals this is flaming unbeleivable

i am so thankfull this will save me almost half a day of painstaking work

:)

Kindest Regards to all

Merc

[mercmannick]

the notcounted i take it is the ones CNF :)

Thanks Peeps
:beerchug:

[mercmannick]

Peeps is there anyway to modify so it creates new sheet and places the msgbox output onto the new sheet , to be able to print counts


Thanks in advance

Merc

[Bob Phillips]

Peeps is there anyway to modify so it creates new sheet and places the msgbox output onto the new sheet , to be able to print counts.

Replace



MsgBox "Total Count " & vbCrLf & _
"========================" & vbNewLine & _
"Current Week : " & iCountCurrentWeek & vbCrLf & _
"Next 1 - 2 Week : " & iCount1to2Week & vbCrLf & _
"Next 2 - 3 Week : " & iCount2to3Week & vbCrLf & _
"Next 3 weeks and later : " & iCount3toAll & vbNewLine & _
"Not counted : " & cNotIncluded, , "Weekly Counts"


with


Dim shTotals As Worksheet
On Error Resume Next
Set shTotals = Worksheets("Totals")
On Error GoTo 0
If shTotals Is Nothing Then
Worksheets.Add.Name = "Totals"
Else
shTotals.Activate
shTotals.Cells.ClearContents
End If
Range("A1").Value = "Current Week :": Range("B1").Value = CountCurrentWeek
Range("A2").Value = "Next 1 - 2 Week :": Range("B2").Value = iCount1to2Week
Range("A3").Value = "Next 2 - 3 Week : ": Range("B3").Value = iCount2to3Week
Range("A4").Value = "Next 3 weeks and later :": Range("B4").Value = iCount3toAll
Range("A5").Value = "Not counted :": Range("B5").Value = cNotIncluded

[mercmannick]

superb guys just misses out current weeks count

Merc

[mercmannick]

sorry was me my apologies it pastes the contents onto cell "A1" in current sheet

HeHe

[mercmannick]

Peeps

How do i make the Area where the contents of count pasted to "A1:B5" have a thick border and out and inside
and coloured


Regards

Merc :cloud9:

[Bob Phillips]

How do i make the Area where the contents of count pasted to "A1:B5" have a thick border and out and inside
and coloured

Tools>Macro>Record Macro ..., do it manually, Stop Macro, look at the cod,and add it to the macro.

[mercmannick]

Xld all done

Thanks all you peeps for the hekp

Merc