Automate - manual made macro

[k0st4din]

Hello everybody,
I am writing you with great asking for help and hope someone can help me.
I got in a lot of dead end with the making of macro.
More than a month in another forum was discussed and no one could help, although I tried with all my strength to explain countless examples did and video to show you how to do things by hand, and even hand-made macros, but alas - final was devastating.
Please for some assistance from your side, dropping the link with all uploaded and shown in 6 pages of other forum. I will put the macro that I did manual and video which explain (show) what and how and why deleted.
I beg you, if something is not clear ask me.
http://www.mrexcel.com/forum/excel-questions/843787-help-automate-manual-made-macro.html#post4108228
Video
https://www.youtube.com/watch?v=tAODp5dguek&feature=youtu.be

[jonh]

DeleteAfter takes 3 arguments
m = number of months (6)
sht = sheet conatining table
del = true/false. If true rows are deleted. If false rows are highlihted (for testing.)


Type rw
dt As Date
s As String
r As Integer
End Type

Sub TEST()
DeleteAfter 6, ActiveSheet, False
End Sub

Sub DeleteAfter(m As Byte, sht As Worksheet, del As Boolean)
sortcols sht

Dim rg As Range, r As Range, cr As rw, sr As rw, pr As rw
Set rg = Range("b2:j" & Range("a1").End(xlDown).Row)
For Each r In rg.Rows
pr = cr
cr.dt = r.Cells(3)
cr.r = r.Row
cr.s = r.Cells(1) & r.Cells(6) & r.Cells(9)
If cr.s <> sr.s Then
If sr.r <> 0 Then
If mdiff(Date, sr.dt) > m Then
If del Then
Rows(sr.r + 1 & ":" & pr.r - 1).Delete
Else
hl Rows(sr.r + 1 & ":" & pr.r - 1)
End If
End If
End If
sr = cr
End If
Next

If mdiff(Date, sr.dt) > m Then
If del Then
Rows(sr.r + 1 & ":" & pr.r).Delete
Else
hl Rows(sr.r + 1 & ":" & pr.r)
End If
End If

End Sub

Sub hl(r As Range)
With r.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
End Sub

Sub sortcols(sht As Worksheet)
With sht.Sort
.SortFields.Clear
.SortFields.Add Range("G2:G24"), xlSortOnValues, xlAscending, , xlSortNormal
.SortFields.Add Range("J2:J24"), xlSortOnValues, xlAscending, , xlSortNormal
.SortFields.Add Range("D2:D24"), xlSortOnValues, xlAscending, , xlSortNormal

.SetRange Range("A1:N24")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

Function mdiff(LDate As Date, EDate As Date) As Integer
mdiff = (Year(LDate) - Year(EDate)) * 12 + Month(LDate) - Month(EDate)
End Function

[jonh]

Oops. I didn't really test the delete and it doesn't work properly (needs to be done in reverse.)
Test the highlight and if that seems ok I'll look at fixing the delete option.

[k0st4din]

Hello
First I want to thank you for your responsiveness.
Will attach the table after I tried your macro and note in red - which should not be deleted and yellow - which must be deleted.
To understand the idea must be selected each number separately (column 7) and then check the products.
I guess from there is a discrepancy, and some things are not true.
And just to mention that this is just an example, my rows are pretty more than 750,000.
The test is in "Sheet2".

Counting things this way:
Hypothetically if April is the last month received it follows:
April
March - 1 month back - deletes
February - 2 months back - deletes
January - 3 months back - deletes
December - four months back - deletes
November - 5 months back - deletes
October - six months back - deletes
Ie we have for the last month 6 months back.

---------------------------------------------------------------------------------


However, if:
April
January - 3 months back - not delete
December - 4 months back - not delete
November - 5 months back - not delete
From last month - I do not count back - 6 months back
If you have questions, I am available.
Many thanks again.

[jonh]

Delete should work now.


Option Explicit

Type rw
dt As Date
s As String
r As Integer
End Type

Sub TEST()
DeleteAfter 6, ActiveSheet, False
End Sub

Sub DeleteAfter(m As Byte, sht As Worksheet, del As Boolean)
sortcols sht, Range("a1").End(xlDown).Row

Dim rg As Range, r As Range, cr As rw, sr As rw, pr As rw, i As Long
Set rg = Range("b2:j" & Range("a1").End(xlDown).Row)

For i = rg.Rows.Count To 1 Step -1
Set r = rg.Rows(i)
pr = cr
cr.dt = r.Cells(3)
cr.r = r.Row
cr.s = r.Cells(1) & r.Cells(6) & r.Cells(9)
If cr.s <> sr.s Then
If sr.r <> 0 Then
If mdiff(Date, pr.dt) > m Then
If del Then
Rows(sr.r - 1 & ":" & pr.r + 1).Delete
Else
hl Rows(sr.r - 1 & ":" & pr.r + 1)
End If
End If
End If
sr = cr
End If
Next

If mdiff(Date, pr.dt) > m Then
If del Then
Rows(sr.r - 1 & ":" & pr.r).Delete
Else
hl Rows(sr.r - 1 & ":" & pr.r)
End If
End If

End Sub

Sub hl(r As Range)
With r.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
End Sub

Sub sortcols(sht As Worksheet, r As Long)
With sht.Sort
.SortFields.Clear
.SortFields.Add Range("G2:G" & r), xlSortOnValues, xlAscending, , xlSortNormal
.SortFields.Add Range("J2:J" & r), xlSortOnValues, xlAscending, , xlSortNormal
.SortFields.Add Range("D2:D" & r), xlSortOnValues, xlAscending, , xlSortNormal
.SetRange Range("A1:N" & r)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

Function mdiff(LDate As Date, EDate As Date) As Integer
mdiff = (Year(LDate) - Year(EDate)) * 12 + Month(LDate) - Month(EDate)
End Function

[k0st4din]

Hello
after placing the macro again only my stained cells (this is very clever to be able to see if the lines are correct), but:
"jonh said:

Delete should work now." ->> First - do not delete them, and only them colored and is very cool

Second - assuming that this is the final macro, then please see number 7032 (assuming that once colored - it should be deleted, then only this number is incorrect) - because of last month received, the product not meeting 6 times back - therefore should not be deleted.
All other numbers and products are correct and should be deleted (and the color is correct).
I guess I'm not mistaken by placing the entire range of several macros in one module?

Link to picture (http://prikachi.com/images.php?images/473/8078473s.jpg)

I think there is something very little to fix it in the macro.
You're a great guy.
Thank you warmly.

[k0st4din]

I just might add one more thing: :)


You accept that under any number of column G - check each product (J) Does repeated 6 months back (D) obtained from the last month?

[jonh]

No, I was checking time span based on the current date. I've changed it so that it uses the first and last dates in each group.

I've also fixed a couple of bugs.

Groups are defined by columns B, G and J

If you don't want to include B change

cr.s = r.Cells(2) & r.Cells(7) & r.Cells(10)
to
cr.s = r.Cells(7) & r.Cells(10)



Type rw
dt As Date
s As String
r As Integer
End Type

Sub TEST()
DeleteAfter 6, ActiveSheet, False
End Sub

Sub DeleteAfter(m As Byte, sht As Worksheet, del As Boolean)

With sht.Cells.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With

sortcols sht, sht.Range("a1").End(xlDown).Row

Dim rg As Range, r As Range, cr As rw, sr As rw, pr As rw, i As Long
Set rg = sht.Range("a1:j" & sht.Range("a1").End(xlDown).Row)

For i = rg.Rows.Count To 1 Step -1
Set r = rg.Rows(i)
pr = cr
cr.dt = r.Cells(4)
cr.r = r.Row
cr.s = r.Cells(2) & r.Cells(7) & r.Cells(10)
If cr.s <> sr.s Then
If sr.r <> 0 Then
If sr.r - pr.r > 1 Then
If mdiff(sr.dt, pr.dt) > m Then
If del Then
sht.Rows(sr.r - 1 & ":" & pr.r + 1).Delete
Else
hl sht.Rows(sr.r - 1 & ":" & pr.r + 1)
End If
End If
End If
End If
sr = cr
End If
Next

End Sub

Sub hl(r As Range)
With r.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
End Sub

Sub sortcols(sht As Worksheet, r As Long)
With sht.Sort
.SortFields.Clear
.SortFields.Add Range("G2:G" & r), xlSortOnValues, xlAscending, , xlSortNormal
.SortFields.Add Range("J2:J" & r), xlSortOnValues, xlAscending, , xlSortNormal
.SortFields.Add Range("D2:D" & r), xlSortOnValues, xlAscending, , xlSortNormal
.SetRange Range("A1:N" & r)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

Function mdiff(LDate As Date, EDate As Date) As Integer
mdiff = (Year(LDate) - Year(EDate)) * 12 + Month(LDate) - Month(EDate)
End Function

[k0st4din]

Hello
I have a few questions:
Can you do it - when doing sorting selected columns have alignment (displacement) in the range A2:AC (as needed) - because we do ranking (sorting) only to column J, then it does not rearrange information .
And the last question that I find it very strange (I simply have no explanation for the final result) - in the example we work everything occurs as we want, but when I put it in the original file - colored lines showing me not 6 months back, showed me 7 or no staining showed me some lines?
Please view the link to the photo
http://prikachi.com/images.php?images/297/8081297L.jpg
Thank you warmly. You are great

[jonh]

Sorry, I don't understand either question.

In the screenshot
7/2014 to 3/2015 = 8 months so the rows should be deleted/highlighted, which they are, so I can't see anything wrong there.

[k0st4din]

Hello
not eight months.
I will try again to explain:
Macro is wonderful (I have no words to explain how happy I am), but:
Follow this logic: each last month counting back 6 months (not eight, nine, ten, etc.) - if you have six months to stain and delete. If there are not 6 months back - remains information (not delete) and wait for the next month and re-checking, etc.
I beg you consider my post 4
Thank you very much.
Regards

[jonh]

You want to include the sixth month? :dunno

Whether data is deleted or not is decided by this line of code


If mdiff(sr.dt, pr.dt) > m Then


> m : greater than 6 (7,8,9...)

>= m : 6 or greater (6,7,8,9...)
= m : must be 6
< m : less than 6 (5,4,3...)
<= m : less than or equal to 6 (6,5,4,3...)




If I run the macro on TEST 3d.xlsm I get this. All groups are deleted except one.


start: 01/08/2014 end 03/01/2015 months 5 Delete = NO ML_7032_SIM20
start: 01/04/2014 end 03/01/2015 months 9 Delete = YES ML_3207_SIM20
start: 27/06/2014 end 22/01/2015 months 7 Delete = YES LP_2904_SIM20
start: 27/06/2014 end 22/01/2015 months 7 Delete = YES LP_2904_QUIN20/12.5
start: 13/05/2014 end 06/01/2015 months 8 Delete = YES LK_2706_SIM10
start: 25/06/2014 end 05/01/2015 months 7 Delete = YES NB_2509_CLOP



If I run the macro for the data posted here (post #32)
link (http://www.mrexcel.com/forum/excel-questions/843787-help-automate-manual-made-macro-4.html#post4117200)

I get the result you asked for


start: 01/04/2014 end 03/01/2015 months 9 Delete = YES ML_3207_SIM20
start: 27/06/2014 end 22/01/2015 months 7 Delete = YES LP_2904_SIM20
start: 27/06/2014 end 22/01/2015 months 7 Delete = YES LP_2904_QUIN20/12.5
start: 13/05/2014 end 06/01/2015 months 8 Delete = YES LK_2706_SIM10
start: 25/06/2014 end 05/01/2015 months 7 Delete = YES NB_2509_CLOP

All groups are > 6 months.



Run the macro on data that gives the wrong result and upload the file.

[jonh]

Ah, I think it just clicked. :)

Post 4, you don't delete the second group because February and March are missing.

If you only have one row for each month a quick fix might be to change this


If sr.r - pr.r > 1 Then
If mdiff(sr.dt, pr.dt) > m Then

to this


If sr.r - pr.r >= m Then
If mdiff(sr.dt, pr.dt) >= m Then

[k0st4din]

Hello jonh,
little delayed answer, but I wanted to look at all the opportunities offered to me.
Since I am required to be six months or more it seemed to me these two versions (> m and that >= m).
As this option -> (> m) - me does not work and painted lines -> I do not know why.
In this version - (>= m) - work, but always counting back five months from last month, which I have in the table.
Please take a look, why is it so.

If sr.r - pr.r > 1 Then
If mdiff(sr.dt, pr.dt) > m Then '- dont work
------------------------------------------------------------------------
If sr.r - pr.r > 1 Then
If mdiff(sr.dt, pr.dt) >= m Then '- work for me, but only 5 months back count
After lengthy trials and tests I caught everything and described in the attached table you be easier, but if there are questions I'm available.

P.S. - jonh said: Post 4, you don't delete the second group because February and March are missing.
Answer: I did not delete them, because I have five months back for the last month in the table (in the example) and not because missing - ie even if you do not see them some months back, it does not mean that they should not be counted.For example: I get tomatoes in April from company X, but did not order from this company in March and February, but I ordered the same tomatoes in January. Which in turn census back in April made 3 months back, not 1 month back
I guess that is understandable :)


Thank you warmly jonh.

[jonh]

I see, you only want to leave the latest date, not the earliest and latest.

Replace this bit...


If del Then
'sht.Rows(sr.r - 1 & ":" & pr.r + 1).Delete
sht.Rows(sr.r - 1 & ":" & pr.r).Delete
Else
'hl sht.Rows(sr.r - 1 & ":" & pr.r + 1)
hl sht.Rows(sr.r - 1 & ":" & pr.r)
End If

sr = start row
cr = current row
pr = previous row

To actually delete rows the code needs to work from bottom to top (last row to first), so the 'start row' is the latest date and if 'current row' is not part of the current 'group' 'previous row' is effectively the end of the group.
sr.r, pr.r and cr.r are the row numbers for each line.

so if you have a data group spanning rows 10 - 20

sr.r=20
cr.r=9
pr.r=10

since you want to leave the latest date (sr) and delete the oldest (pr)


sht.Rows(sr.r - 1 & ":" & pr.r).Delete
is equivalent to

sht.Rows(19:10).Delete

[k0st4din]

Hello
everything is good now. I have another question - as this is the only example in this column name 4 I have text and when he pushed the button tells me that there is an error (because this name 4 in my table says "date of products") - how can you fix it?
And the last question: how when doing layout on our desires and these three columns can rearrange information for each column line to AC?
Ie which of these two lines to change the range, so I can rearrange information for lines?

Dim rg As Range, r As Range, cr As rw, sr As rw, pr As rw, i As Long
Set rg = sht.Range("a1:j" & sht.Range("a1").End(xlDown).Row) ' - here to change
Set rg = sht.Range("a1:AC" & sht.Range("a1").End(xlDown).Row)
' or here
.SetRange Range("A1:N" & r) ' - here to change
.SetRange Range("A1:AC" & r)
I think this is the last, which must be fixed and will be ready.
Thank you very much

[jonh]

To fix the error, change


cr.dt = r.Cells(4)

to


If i <> 1 Then cr.dt = r.Cells(4)

If you change the sort, the code probably wont work properly. You need to sort it again afterwards.

So create another version of sortcols, e.g. sortcols_post

then you'll need to change the lines


.SortFields.Add Range("G2:G" & r), xlSortOnValues, xlAscending, , xlSortNormal
.SortFields.Add Range("J2:J" & r), xlSortOnValues, xlAscending, , xlSortNormal
.SortFields.Add Range("D2:D" & r), xlSortOnValues, xlAscending, , xlSortNormal

They are sorting columns G, J and D in that order.

and call your new sub at the end of DeleteAfter, i.e.


Next
sortcols_post sht, sht.Range("a1").End(xlDown).Row
End Sub

[k0st4din]

Hello jonh
Error is fixed and now works very well.
-------------------------------------------------
I'll send you back the table and have yellow colored lines to try to explain what happens during sorting. For the second, you've explained, I do not understand it and do not know how to add and where to add it (can you put it in the macro?).
Ie - if the hypothetical sort columns D, G, J, and if row 2 (ie information move as row 35) - move everything from A to AC for the corresponding order.
If it can do this thing?
If I can not move my information is pointless ranking since its obfuscate data A....:AC......
This is the last thing we need to get (think going to happen)
Thank you warmly for the efforts of you, because I definitely can not do it. Maybe small and petty things, but to me are not known.
I have no words to thank you.
I'm deeply grateful that there are people like you. :bow:

[jonh]

Oh, right. The initial sort range is the wrong size.

You were correct. :)

.SetRange Range("A1:N" & r) ' - here to change
.SetRange Range("A1:AC" & r) <-- to this

It shouldn't matter about the other stuff.

[k0st4din]

Thank you, thank you, thank you very much.
We're finally at the finish and now everything works as it should.
Be alive and well jonh
Regards

[k0st4din]

Hello jonh,
please for a tiny, microscopic assistance - nothing to add to the final result may be ordered by the column B2:B?
I tried to add here and column B, but I do not get the things I know mistaken with this arrangement?

Sub sortcols(sht As Worksheet, r As Long)
With sht.Sort
.SortFields.Clear
.SortFields.Add Range("G2:G" & r), xlSortOnValues, xlAscending, , xlSortNormal
.SortFields.Add Range("J2:J" & r), xlSortOnValues, xlAscending, , xlSortNormal
.SortFields.Add Range("D2:D" & r), xlSortOnValues, xlAscending, , xlSortNormal
.SortFields.Add Range("B2:B" & r), xlSortOnValues, xlAscending, , xlSortNormal 'here I added
.SetRange Range("A1:AC" & r)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
This should be or is nonsense, what have I done?
Thank you very much.

[jonh]

Looks ok.
You'll need to attach an example and clearly show why/where it's not working to get any help.

Remember, the sort works in that order; G,J,D,B. So if you want it to sort B first, move it to the top.

[k0st4din]

Yes John, only shifted and placed at the top column B and everything was fine.
My mistake was that I had set Finally, at the bottom.
Thanks so much for your advice