Help with macro code alteration if possible?

[Barryj]

I am trying to alter this code which on its own works perfect, but when it pastes into the destination sheet thats when I have a few problems.

What I am trying to do is run a golf score sheet that covers three rounds, the players are able to drop their worst score from the three rounds provided they play the three rounds, if they only play two rounds both scores count.

The macro that I have searches the three sheets and puts the scores in the relevant columns.

But what I need this macro to do now is if there are three scores then minus the worst score based on column B from sheets 1,2,3 and add the other scores and then sort the scores for the results.

I tried using cell based formula for the minus of the worst score but it slowed the rest of the workbook to a snails pace.

Sheet 1,2,3 have names in column A then data in columns B,C,D,E,F

Sheet 4, the destination sheet, the first round scores are in columns A names, then B,C,D,E,F for data:

Second round scores data in columns G,H,I,J,K.

Third round scores data in columns L,M,N,O,P

I then need the sheet to be sorted by columns Q,R,S,T,U with names in column A included in the sort.

My current macro looks like this, it first sorts sheet 1 then searches the other sheets.

Private Sub Worksheet_Activate()
Range("A2", Range("F65536").End(xlUp).Address).Select
Selection.Sort Key1:=Range("F2"), Order1:=xlAscending _
, Key2:=Range("E2"), Order2:=xlAscending _
, Key3:=Range("D2"), Order3:=xlDescending
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending _
, Key2:=Range("C2"), Order2:=xlAscending _
'clear out any existing data
Sheets("A Grade Stroke Final Results").Rows("2:" & _
Sheets("A Grade Stroke Final Results").Cells(Rows.Count, _
"A").End(xlUp).Row).ClearContents

For Each ce In Sheets("A Grade Rd1").Range("a2:a" & _
Cells(Rows.Count, "a").End(xlUp).Row)
outrow = Sheets("A Grade Stroke Final Results").Cells(Rows.Count, _
"A").End(xlUp).Offset(1, 0).Row
FR2 = 0
FR3 = 0
On Error Resume Next
FR2 = WorksheetFunction.Match(ce, Sheets("A Grade Rd2").Range("a:a"), 0)
FR3 = WorksheetFunction.Match(ce, Sheets("A Grade Rd3").Range("a:a"), 0)
On Error GoTo 0
If FR2 Then
Sheets("A Grade Stroke Final Results").Range("a" & outrow).Value = ce
Range(ce.Offset(0, 1), ce.Offset(1, 5)).Copy _
Destination:=Sheets("A Grade Stroke Final Results").Range("B" & outrow)
Sheets("A Grade Rd2").Range("B" & FR2 & ":F" & FR2).Copy _
Destination:=Sheets("A Grade Stroke Final Results").Range("G" & outrow)
End If
If FR3 Then
Sheets("A Grade Stroke Final Results").Range("a" & outrow).Value = ce
Range(ce.Offset(0, 1), ce.Offset(0, 5)).Copy _
Destination:=Sheets("A Grade Stroke Final Results").Range("B" & outrow)
Sheets("A Grade Rd3").Range("B" & FR3 & ":F" & FR3).Copy _
Destination:=Sheets("A Grade Stroke Final Results").Range("L" & outrow)
End If
Next ce
End Sub

I would appreciate any help you could provide, thankshttp://vbaexpress.com/forum/images/smilies/banghead.gif

[Bob Phillips]

Can you post a workbook?

[johnske]

Hi barry, and welcome to VBAX. I edited your post earlier to include VBA tags and some line-breaks to make the code more readable and I see you've now edited them out... :doh:

It really does help if you would include VBA tags as the code then appears as it does in the VBE window and is thus of a more familiar appearance that assists helpers, allowing them to read it a little more easily.

Regards,
John :)

[mdmackillop]

Can you post a workbook?
Hi Barry,
Welcome to VBAX
You can post a workbook using Manage Attachments accessed from the Go Advanced button.
BTW, if you select your code and click on the VBA button, it formats it as above for easier reading. If you can use linebreaks in long code lines, this helps as well, by avoiding the need to scroll.
Regards
MD

[mdmackillop]

Hi barry, and welcome to VBAX. I edited your post earlier to include VBA tags to make the code more readable and I see you've now edited them out... :doh:

Me also! Too many editors here.

[Barryj]

Sheet 1 shows the destination sheet and how it should look after changes are made, data in columns Q to U this should then be sorted as previous post.

Hope this helps, thanks for the intrest.

[mdmackillop]

Hi Barry,
Its late here, but I've had a quick look and will get back to you (unless someone is there first). Have you had a look at the Rank function?
Regards
MD

[Bob Phillips]

Sheet 1 shows the destination sheet and how it should look after changes are made, data in columns Q to U this should then be sorted as previous post.

Hope this helps, thanks for the intrest.

Can you explain the relationship between sheet1 and sheet2 as it is not clear to me. For instnace, where does R Jones' 76 38 3 5 4 show up, and what do those numbers signify (78 I can guess, but 3, 5 and 4?).

[Barryj]

Ok, the information on sheet 1 is the destination sheet for the VBA code I posted earlier, the information on sheet 2 is gathered from another sheet and macro.

What the macro I posted does is search 3 other sheets and finds a matching name, as the person must play 2 of the 3 rounds.

This information is gathered form 3 sheets identical to sheet 2 of the attachment, once the macro is run it then sends this information to sheet1 of the attachment.

The name that is displayed on sheet 1 is a result of the VBA code posted searching the 3 sheets identical to sheet 1.

The data is displayed as round 1 then 2 then three, as you will see some names only have 2 sets of data, this is because they only played in 2 of the three rounds.

The number 78 is their score, the number 38 is their score for the last 9 holes of the round, the number 3 is their score on the last hole and the number 5 is their score on the second last hole, the number 4 is their score for the third last hole, this attachment is for count back purposes.

So when the information is placed on sheet1 I need the macro to take the 2 lowest scores based on columns B,G,L & the 4 Columns to the right, add the scores together and place in columns Q,R,S,T,U & then sort the data in that order also including their name.

If they only play 2 rounds then these 2 scores have to be used.

I hope this helps make things a little clearer.

[Bob Phillips]

You can use a formula for this.

In Q2 enter

=SUMPRODUCT(SMALL(IF(N(OFFSET(B2:$P2,0,{0,5,10},1,1))=0,999,N(OFFSET(B2:$P2 ,0,{0,5,10},1,1))),{1,2}))

and copy across and down.

[Barryj]

When I tried a formula approach when the macro placed the information into the destination sheet it wiped out the formulas, it also slowed down the entire workbook to a snails pace.

[Bob Phillips]

When I tried a formula approach when the macro placed the information into the destination sheet it wiped out the formulas, it also slowed down the entire workbook to a snails pace.

That must be because your code overwrites it, it should be amended to stop. As for performance, what have you got, 100,000 players?

[Barryj]

I will try the formula you suggested, but how do I ammend the code to not wipe the formula each time the data is put into this sheet.

Do the cells need to be formatted at all to help eliminate this problem.

[Bob Phillips]

Try this

[Barryj]

Hi that is exactly what I am after, the only problem that I have is that when I put the code into my workbook it is searching and dragging information from other sheets that match the persons name then ending in a run time error 1004 on the last line.

Can it be coded to just look at A Grade Rd1, A Grade Rd2 & A Grade Rd3 if that is possible, this will hopefully solve the problem, other than that it is brilliant, and thankyou very much for your time on this. Barry.

a problem that I found also was that if a person did not play the first round then they were put on the bottom table when it did its sort function, but if I added their name and socres into round 1 then it sort as it should.:doh:

[Bob Phillips]

Hi that is exactly what I am after, the only problem that I have is that when I put the code into my workbook it is searching and dragging information from other sheets that match the persons name then ending in a run time error 1004 on the last line.

Can it be coded to just look at A Grade Rd1, A Grade Rd2 & A Grade Rd3 if that is possible, this will hopefully solve the problem, other than that it is brilliant, and thankyou very much for your time on this. Barry.

Okay, try this. It is actually a bit tighter code because of the changes.

[Barryj]

I am getting a run time error on this line:
.Range("Q2:U2").AutoFill .Range("Q2:U2").Resize(.Cells(Rows.Count, "A").End(xlUp).Row - 1)
Also if a person does not play in the first round regardless of their score they are sorted last in the final results sheet.

Thanks again for the help.

[Bob Phillips]

I am getting a run time error on this line:
.Range("Q2:U2").AutoFill .Range("Q2:U2").Resize(.Cells(Rows.Count, "A").End(xlUp).Row - 1)

I am not getting this. At what stage does this happen?



Also if a person does not play in the first round regardless of their score they are sorted last in the final results sheet.

I didn't change your sort in any way. What are the sort criteria that you want?

[Barryj]

I have included the file which I posted into my work book and it shows the run time error + the problem with the results, if a person does not play the first round they will be sorted to the last place regardless of score.

This was also happening in the first file you posted, hope this helps, thanks again.

[Bob Phillips]

... if a person does not play the first round they will be sorted to the last place regardless of score.

I repeat .. I didn't change your sort in any way. So it sorts as you originally defined it. What are the sort criteria that you want?

[mdmackillop]

I tried the code and got the same error. Try the following slight revision.
Changes made noted

Option Explicit
Private Sub Worksheet_Activate()
Dim sh As Worksheet

Application.ScreenUpdating = False

With Me
'clear out any existing data
.Rows("2:200").ClearContents

'*****Change from B Grade
PostData "A Grade Rd1", 2
PostData "A Grade Rd2", 7
PostData "A Grade Rd3", 12

.Range("Q2:U2").Formula = "=SUMPRODUCT(SMALL(IF(N(OFFSET(B2:$P2,0,{0,5,10},1,1)) _
=0,999,N(OFFSET(B2:$P2 ,0,{0,5,10},1,1))),{1,2}))"
.Range("Q2:U2").AutoFill .Range("Q2:U2").Resize(.Cells(Rows.Count, "A") _
.End(xlUp).Row - 1)

.Range("A2:Z2").Resize(.Cells(Rows.Count, "A").End(xlUp).Row).Sort _
Key1:=.Range("F2"), _
Order1:=xlAscending, _
Key2:=.Range("E2"), _
Order2:=xlAscending, _
Key3:=.Range("D2"), _
Order3:=xlDescending
.Range("A2:Z2").Resize(.Cells(Rows.Count, "A").End(xlUp).Row).Sort _
Key1:=.Range("B2"), _
Order1:=xlAscending, _
Key2:=.Range("C2"), _
Order2:=xlAscending

End With

Application.ScreenUpdating = True

End Sub
Private Sub PostData(SheetName As String, StartCol As Long)
Dim sh As Worksheet
Dim ce As Range
Dim iRow As Long
On Error Resume Next
Set sh = Worksheets(SheetName)
On Error GoTo 0

If Not sh Is Nothing Then
For Each ce In sh.Range("A2").Resize(sh.Cells(Rows.Count, "A").End(xlUp).Row)
iRow = 0

On Error Resume Next
'***** Change to sh.range
iRow = Application.Match(ce.Value, sh.Range("A:A"), 0)
On Error GoTo 0
If iRow = 0 Then
If Me.Range("A2").Value = "" Then
iRow = 2
Else
iRow = Me.Range("A1").End(xlDown).Row + 1
End If
Me.Cells(iRow, "A").Value = ce.Value
End If
'***** Next line added
Me.Cells(iRow, "A").Value = ce.Value
ce.Offset(0, 1).Resize(1, 5).Copy Me.Cells(iRow, StartCol)
Rows(2).Copy
Rows(ce.Row).PasteSpecial Paste:=xlPasteFormats
Next ce
End If
End Sub

[Barryj]

:banghead: It shows a compile error and syntax error.

Thanks for the continued help.

[Bob Phillips]

:banghead: It shows a compile error and syntax error.

Thanks for the continued help.

You haven't answered my question on sorting. I have an amended version ready apart from sorting.

[mdmackillop]

My apologies, I made an error with a line break. Here's the "working" example.

[Barryj]

Works great, just one question on the destination sheet in the last row columns Q to U show 1998 in each column even though there is no names or scores in this row, any thoughts?

I really have to thankyou for your time on this, again thankyou.:thumb

[mdmackillop]

I've only looked at the code from a debugging point of view, to solve your error message. I've not tried to follow the logic of XLD's solution.
Regards
MD