VBA code to select and copy a column based on a date and paste it into a specific sheet.

[Spuggy54]

Hi,

I'm new to posting VBA problems so please let me know if I haven't posted this problem correctly.

I've created a workbook to enter scores for a golf team competition. As background information, each time a team wins, the players in that team have their golf handicaps decreased by 1. Further, if the same team don't then win the following match, the players in that team have their handicaps increased by 1. This can be seen in the attached workbook in sheet "Handicaps". The functions in this sheet checks the scores of each match entered in the sheets "ScoreMtch1, ScoreMtch2, etc. and calculates which teams player's handicaps are decreased or increased for the next competition.

So far so good!!

Before the next match I send out each teams player's new handicaps for the forthcoming competition. I've created sheets for each team and have created a macro to populate each teams handicaps for the forthcoming competition. The naming format for the macros to do this is <TeamName>Hcps. e.g. BelfrymenHcps.

At the moment I am having to change the macro code before each competition so that it pulls each teams handicaps from the correct column in the 'Handicaps' sheet based on the date of the next competition. Presently, the macro successfully creates the team's handicaps from column "D", 4-Dec, which was the first match, but I will now have to change the macro code so that it pulls the data through from the next column i.e. the next competition date, which in my example is column "E" 8-Jan, and would like to automate this process if at all possible.

I hope this all make some sense when you look at the spreadsheet I've attached but let me know if you need further clarification.

Note: There is also a sheet "StartHcps" that compiles all the team handicaps in one sheet use to create the scorecards for the next competition and would also like to be able to automate the change to this macro also which is called "CreateHandicapsSheet.

[protonLeah]

Did you post the right file? The sheet names and macros don't match descriptions above

[Spuggy54]

Thought I had. Just a moment.

[Spuggy54]

Apologies but I downloaded the wrong file.

[protonLeah]

Is this what you want?

Option Explicit
Sub test()
    Dim Teams As Variant
    Dim TeamName As Variant
    Teams = Array("Divots'R'Us", "Hogan 's Heroes", "Jammy Dodgers", _
    "Joe 90", "Oliver 's Army", "Team Seve", "The 49ers", "The Belfrymen", _
    "The Blue Villains", "The Cowboys", "The Fab Four", "The Good Fellas", _
    "The Longshots", "Zulu Warriors")

    For Each TeamName In Teams
        Call Ceate_Hcps(TeamName )
    Next TeamName
End Sub
Public Function Ceate_Hcps(ByVal TeamName As String)
    Dim NewSheet As Boolean
    
    '
    ' CreateHandicapsSheet Macro
    '
    
    On Error Resume Next
    Worksheets(TeamName).Select
    If Err.Number <> 0 Then
        NewSheet = True
        Worksheets.Add.Name = TeamName
    End If
    If Not NewSheet Then ClearOldSheet
    
    Range("A1:B1").Select
    
    With Selection
        .Font.Size = 16
        .Font.Bold = True
        .Interior.ColorIndex = 36
    End With
    
    Range("A1").Value = "Date"
    Range("B1").Value = Date
    
    Range("A2").Select
    
    With Selection
        .Font.Size = 14
        .Font.Bold = True
        .Interior.ColorIndex = 36
    End With
    
    'Range("A3:B3").Merge True
    
    Range("A2").Value = "Start Hcps"
    
    Range("A3:B3").Select
    With Selection
        .Font.Size = 12
        .Font.Bold = True
        .Interior.ColorIndex = 34
    End With
    
    Range("A3").Value = "Team/Players"
    Range("B3").Value = "Hcaps"
    
    With Selection
        .Font.Size = 14
        .Font.Bold = True
        .Interior.ColorIndex = 36
    End With
    
    Range("A1").Select
        Selection.Offset(3, 0).Select
                Selection.Formula2R1C1 = _
                "=OFFSET(INDIRECT(ADDRESS(6,1,1,TRUE,""Handicaps"")),5,0,,)"
        Selection.Offset(1, 0).Select
            ActiveCell.Select
                Selection.Formula2R1C1 = _
                "=OFFSET(INDIRECT(ADDRESS(6,1,1,TRUE,""Handicaps"")),5,1,,)"
        Selection.Offset(0, 1).Select
            ActiveCell.Select
                Selection.Formula2R1C1 = _
                "=OFFSET(INDIRECT(ADDRESS(6,1,1,TRUE,""Handicaps"")),5,4,,)"
        Selection.Offset(1, -1).Select
            ActiveCell.Select
                Selection.Formula2R1C1 = _
                "=OFFSET(INDIRECT(ADDRESS(6,1,1,TRUE,""Handicaps"")),6,1,,)"
        Selection.Offset(0, 1).Select
            ActiveCell.Select
                Selection.Formula2R1C1 = _
                "=OFFSET(INDIRECT(ADDRESS(6,1,1,TRUE,""Handicaps"")),6,4,,)"
        Selection.Offset(1, -1).Select
            ActiveCell.Select
                Selection.Formula2R1C1 = _
                "=OFFSET(INDIRECT(ADDRESS(6,1,1,TRUE,""Handicaps"")),7,1,,)"
        Selection.Offset(0, 1).Select
            ActiveCell.Select
                Selection.Formula2R1C1 = _
                "=OFFSET(INDIRECT(ADDRESS(6,1,1,TRUE,""Handicaps"")),7,4,,)"
        Selection.Offset(1, -1).Select
            ActiveCell.Select
                Selection.Formula2R1C1 = _
                "=OFFSET(INDIRECT(ADDRESS(6,1,1,TRUE,""Handicaps"")),8,1,,)"
        Selection.Offset(0, 1).Select
            ActiveCell.Select
                Selection.Formula2R1C1 = _
                "=OFFSET(INDIRECT(ADDRESS(6,1,1,TRUE,""Handicaps"")),8,4,,)"
    
    Columns("A:B").Select
    Columns("A:B").EntireColumn.AutoFit
    
    Range("B:B").Select
        With Selection
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlBottom
            .Orientation = 0
            .IndentLevel = 0
            .ReadingOrder = xlContext
        End With
    FormatTeamNames
    Range("A1").Select
End Function

[Spuggy54]

Hi,

It's 12.30am here so I'm off to bed unfortunately. I'll give it a try tomorrow if that's ok and get back to you?

Did you test the code in my spreadsheet and if so would it be possible for you send it back to me with the macro installed?

Thanks very much for your help with this one. Much appreciated.

[Spuggy54]

Hi.

I tried running this on the CompScoreTest2 workbook and it's pulling through the wrong data for that team's sheet e.g. the first iteration of the code it pulls through '49ers' team data into the 'Divots'R'Us sheet.

I hope this makes sense and that this helps. Thanks again for helping out.

P.S. I've downloaded an updated workbook 'CompScoreTest2' as I noticed that one of the team Macros weren't pulling through the correct players for that team.

[protonLeah]

Option Explicit
Sub test()
    Dim Teams As Variant
    Dim TeamName As Variant
    Teams = Array("Divots'R'Us", "Hogan 's Heroes", "Jammy Dodgers", _
    "Joe 90", "Oliver 's Army", "Team Seve", "The 49ers", "The Belfrymen", _
    "The Blue Villains", "The Cowboys", "The Fab Four", "The Good Fellas", _
    "The Longshots", "Zulu Warriors")

    For Each TeamName In Teams
        Call Create_Hcps(TeamName)
    Next TeamName
End Sub

Public Function Create_Hcps(ByVal TeamName As String)
    '
    ' CreateHandicapsSheet Macro
    '
    Dim NewSheet        As Boolean, _
        TeamStartRow    As Variant, _
        TeamLastRow     As Variant, _
        LastMatchDate   As Variant, _
        PlayerName      As Variant, _
        DestRow         As Long
    
    On Error Resume Next
    Worksheets(TeamName).Select
    If Err.Number <> 0 Then
        NewSheet = True
        Worksheets.Add.Name = TeamName
    End If
    If Not NewSheet Then ClearOldSheet (TeamName)
    
    With Worksheets(TeamName)
        With .Range("A1:B1")
            .Value = Array("Date", Date)
            .Font.Size = 16
            .Font.Bold = True
            .Interior.ColorIndex = 36
        End With
        With .Range("A2")
            .Value = "Start Hcps"
            .Font.Size = 14
            .Font.Bold = True
            .Interior.ColorIndex = 36
        End With
    
        'Range("A3:B3").Merge True
        
        With .Range("A3:B3")
            .Value = Array("Team/Players", "Hcaps")
            .Font.Size = 12
            .Font.Bold = True
            .Interior.ColorIndex = 34
        End With
        
        With .Range("A4")
            .Font.Size = 14
            .Font.Bold = True
            .Interior.ColorIndex = 36
        End With
    End With 'team name sheet

    With Sheets("Handicaps")
        Set TeamStartRow = .Columns("A").Find(TeamName, after:=Range("A1"), SearchDirection:=xlNext)
        Set TeamLastRow = .Columns("A").Find(TeamName, after:=Range("A1"), SearchDirection:=xlPrevious)
        Set LastMatchDate = .Cells(4, .Columns.Count).End(xlToLeft)
    
        DestRow = 5
        For Each PlayerName In .Range(TeamStartRow.Address, TeamLastRow.Address)
            Sheets(TeamName).Cells(DestRow, "A").Value = .Cells(PlayerName.Row, "B").Value
            Sheets(TeamName).Cells(DestRow, "B").Value = .Cells(PlayerName.Row, LastMatchDate.Column).Value
            DestRow = DestRow + 1
        Next PlayerName
    End With    'copying current handicaps
    FormatTeamNames
End Function

[Spuggy54]

Hi,

Thanks for the response.

I've tried running the macros and I'm getting the following error when running 'Create_Hcps' and not sure why.

Compile error: Wrong number of arguments or invalid property assignment.

This happens on line:

If Not NewSheet Then ClearOldSheet (TeamName) when calling 'ClearOldSheets'.

Hope you can help.

Regards,

Chris

[protonLeah]

Just delete the parenthetical: "(TeamName) "

If Not NewSheet Then ClearOldSheet

I was thinking of passing the name of the sheet to be cleared to the ClearOldSheet macro but ...

[Spuggy54]

Yeh, I thought that might be the case so did delete it out and it ran through ok but it still doesn't pull the correct data through to the correct team sheet at the moment. Also the team name isn't being pulled through to the team sheet into "A4".

Appreciate you help with this.

Chris

[protonLeah]

for the name in A4, add:

        With .Range("A4")
            .Value = TeamName
            .Font.Size = 14
            .Font.Bold = True
            .Interior.ColorIndex = 36
        End With

- Since I'm using xl2016, I don't have the new 365 functions, so many of your calculations result in #NAME? errors.
- Assuming that the team sheets, e.g. Joe 90 are reporting the last match (last column) on the Handicaps sheet, I tested by adding a new date column like Handicaps!G4 = 5-Mar, and filled the column with random numbers in place of your formulas.

* NOTE: Some of your team tab names don't have spaces between the substrings. E.g. tab Joe90 is listed in the AdminLists table as "Joe 90" with a space.
All the ScoresMtchx sheets use the AdminLists table... Another example: "The 49ers" vs. tab "49's"

- Since the code I wrote used the AdminLists table, it won't find those tabs and will create a new sheet and you will end up with both "Joe 90" and the original "Joe90" sheets with the updated values in "Joe 90".

In my tests, all the team sheets picked up the correct team, player and handicap (if it's the last match date(column)).

[Spuggy54]

DISREGARD THIS POST PLEASE.

Hi again,

Thanks for the update.

I deleted all the old team name tabs and let your code create the tabs from the 'AdminLists' which works fine.. The problem now is that the code is pulling through the team name and players for the 49ers team on every new team tab. Obviously the 49ers is correct as per your feedback but all the other team tabs have the same data so I'm not sure why it's working correctly when you test it.

I'll try have a look through the code sometime today myself and see if I can spot the problem and will let you know if do but in the meantime thanks again for you assistance.

Regards,

Chris

[Spuggy54]

Hi again,

Regarding the previous post, when I ran what I thought was the new code, was in fact the old code but not sure why?

Anyway, I've just tested the new code again and it seems to be working although I found on a couple of teams tabs it hadn't entered the player's names and handicaps i.e. Hogan's Heroes and Oliver's Army. I have found the reason though. In the code for the Teams variant there was a space before the apostrophe in both names. I took the spaces out and it's now entering the names and handicaps in those team tabs as well.

So it looks like it is working as I wanted. I'll do some further testing on the live workbook and get back you if that's ok?

In the meantime thanks again for you assistance.

Regards,

Chris

[Spuggy54]

Hi,

Just got around to testing the code on the live worksheet and I'm pleased to tell you that it's working as I wanted.

Thank you so much with your assistance with this. I'll mark the thread as SOLVED.

Kind regards,

Chris