VBA Programming help for New UserA

D

dtp81390

New member
Joined
Oct 26, 2015
Messages
31
Reaction score
0
Points
0
I am in need of help with VBA and planning a workout Routine based on 71 different workout programs.

This is what I am wanting to do essentially in the order that I want it done in.

1. Read a set of inputs from a sheet that read: Program Name (Text), Ownership (Yes or No), Length (Number of Days), Type (Workout Type, ie Cardio, Martial Arts etc.), Difficulty (Beginner to Expert), Desirability (Is this I program I want to do, Scale of 1-5) and Completed (Yes or No). Found in Columns C:I
2. Using a points system with a value associated with each of the parameters (except Program Name) to create a value which prioritizes the workouts. I want this value stored in Column B
3. Then assign a priority number based on their value. The lowest value gets higher priority, duplicate values get the same priority. If ownership is No then there is no Value or Priority assigned color of cells in row change to Red. If completed the priority should go to 0 and color of cells in row change to green.
4. The data should automatically sort by Priority, then by Program Name
5. The Next step would be to randomly select a workout based on a weighted probability.
  • Find the Unique Values for the Priorities since some of them get duplicated if there are duplicate values, and store in cells
  • Count the number of occurrences of that Unique Value and store in cells
  • Priority 1 occurs twice as often as Priority 2 which occurs twice as often as Priority 3 etc. and when multiple programs share the same priority then they divide the probability of that priority between them evenly. I believe the correct formula for this is (1/2^(Priority-1)*X)/Count, where the sum of all of the probabilities =100%. Store these in cells
  • Using these calculated probabilities to then Randomly select a workout program from the list and store in a cell on the Schedule Worksheet
6. Once the program is selected I want the first occurrence of it to have the day # added to it so it would read Program 1: Day 1
7. I then want this to repeat and schedule the next day randomly and store that in the next row so it will then read either Program 1: Day 2 or Program 2: Day 1 etc.
8. Every 7th random selection needs to be a Rest Day and the cell should say Rest Day
9. I want it to schedule 7 days at a time, so it would be 7 random workouts and a Rest Day
10. Lets say that Program 1 has a Length (from step 1) of 12 days
  • Once a Program is scheduled for the same number of days as its Length, then the Completed parameter should switch to Completed, which then changes the priority to 0, which then removes this program from the probability calculation and adjusts the probabilities to account for 1 less workout
11. The ownership for new programs can be toggled to yes at any point and the new program gets figured into the scheduling and probabilities for the next weeks schedule
12. I do not want previous scheduled workouts to be removed from the schedule sheet. The next random program should be placed on the next row, for every program until all of them have been completed.
13. I plan on having a sheet that contains the workout program along with the workout for each day, which will be selected from a drop down. So it will read Program 1: Day 1 in column A and in column B it will read Legs etc. This is so that the Weekly Schedule Worksheet that I have will pull the Program 1:Day 1 from the Schedule Worksheet along with the workout associated with that day. Those workouts will have time and equipment associated with them which will also be pulled into the weekly schedule.
14. All of this will happen each time a Schedule Button is pressed and it will schedule 1 week at a time.

I know that this is a complicated bit of programming and I would like to do the programming myself but have very little experience if someone would be willing to point me in the correct direction on syntax and what methods should be used for each task as well as check over my code that would be greatly appreciated.

I am currently in college, working 2 jobs, and am married with a 1 year old. This is for my second job which is as a self employed health and fitness coach. I really do not have the funds to pay someone to do this.
 
Since no one has responded to this. I thought that I would attempt to learn and write this code myself. I do have a few questions

I have attached the spreadsheet and the code is in there too. Although it is just assigning variables and constants

This is what I want the next action to accomplish

1. Starting in C2 if there is text then move to the next step, else leave cells A2 and B2 blank
2. If H2 is No then continue, else format the entire row (I can enter this code in for the formatting), and leave cells A2 and B2 blank
3. If G2 is Yes then continue, else format the entire row (I will enter the formatting code), and leave cells A2 and B2 blank
4. take the text from E2 and F2 and convert them to a point value (This is what the constants are)
5. Add cell D2 to the points converted in the previous step
6. store answer in cell B2
7. move to the next row until column C is blank
8. sort the data based on the value entered in column B

I think that I can write a good portion of this myself but what I am having difficulty with is how do I have it repeat and move down a row until that row is blank
 

Attachments

  • Workouts.xlsm
    23.7 KB · Views: 25
Here is the current code I have (the one in the provided file is older). Nothing happens when I click the command button in the document

Code: 
Option Explicit

'Define variables


Dim Priority As Integer
Dim pValue As Integer
Dim wLength As Integer
Dim wType As String
Dim wDifficulty As String
Dim wOwnership As String
Dim wCompletion As String


'Define Constants


Const STRENGTH = 0
Const MIXED = 5
Const MARTIALARTS = 10
Const CARDIO = 15
Const DANCE = 20


Const BEGINNER = 0
Const BEGINNERINTERMEDIATE = 5
Const INTERMEDIATE = 10
Const INTERMEDIATEADVANCED = 15
Const ADVANCED = 20
Const EXPERT = 25


'Run Prioritization Command


Private Sub cmdPrioritize_Click()
    Range("A2:H2").Select
    If Range("Workout").Value <> "" Then
        If Range("Completed").Value = "No" Then
            If Range("Ownership").Value = "Yes" Then
                Range("Priority, Completed").Select
                wTypePts
                wDifficultyPts
                Range("B2").Value = wTypePts + wDifficultyPts + Length
            Else
                Range("B2").Value = ""
            End If
        Else
            Range("B2").Value = ""
        End If
    End If
End Sub


'Set points for Workout Type


Private Sub wTypePts()
    Dim wTypePT As Integer
    wType = Range("E2").Value
    Select Case wType
        Case Is = "Strength"
            wTypePT = STRENGTH
        Case Is = "Mixed"
            wTypePT = MIXED
        Case Is = "Martial Arts"
            wTypePT = MARTIALARTS
        Case Is = "Cardio"
            wTypePT = CARDIO
        Case Is = "Dance"
            wTypePT = DANCE
    End Select
End Sub


'Set points for Difficulty


Private Sub wDifficultyPts()
    Dim wDiffPt As Integer
    wDifficulty = Range("F2").Value
    Select Case wDifficulty
        Case Is = "Beginner"
            wDiffPt = BEGINNER
        Case Is = "Beginner/Intermediate"
            wDiffPt = BEGINNERINTERMEDIATE
        Case Is = "Intermediate"
            wDiffPt = INTERMEDIATE
        Case Is = "Intermediate/Advanced"
            wDiffPt = INTERMEDIATEADVANCED
        Case Is = "Advanced"
            wDiffPt = ADVANCED
        Case Is = "Expert"
            wDiffPt = EXPERT
    End Select
End Sub
 
Last edited:
I've almost gotten it working. So far, Ive changed the two trailing subs to functions and now I'm dealing with data discrepancies:)
 
I have updated the code based on discussions in other forums. The links are above to those one.

I am getting errors when I try to call the 3 select case subs wTypePoints, wDifficultyPoints, and wDesirePoints. I need to get them to return an integer that can be added in the pValue formula

Code: 
'Define variables


Dim Priority As Integer
Dim pValue As Integer
Dim wLength As Integer
Dim wType As String
Dim wDifficulty As String
Dim wOwnership As String
Dim wCompletion As String
Dim wDesire As String




'Run prioritization command


Sub cmdPriority_Click()
    Dim Srow As Integer
    Dim wTypept As Integer
    Dim wDifficultypt As Integer
    Dim wDesirept As Integer
    
    Srow = 2
    
    Do Until ActiveSheet.Cells(Srow, 3).Value = "" 'Computes until colum C is blank
        
        If ActiveSheet.Cells(Srow, 9).Value = "No" Then 'If the program is not completed continue with the code
        
            If ActiveSheet.Cells(Srow, 8).Value = "Yes" Then 'If the program is owned continue with the code
                
                wLength = ActiveSheet.Cells(Srow, 4).Value 'Get length of program
                wTypePoints (wTypept) 'Call type points sub
                wDifficultyPoints (wDifficultypt) 'Call difficulty points sub
                wDesirePoints (wDesirept) 'Call desire points sub
                
                ActiveSheet.Cells(Srow, 2).Value = pValue 'Set which cell will get the points calculation
                pValue = wLength + wTypePoints + wDifficultyPoints + wDesirePoints 'Define points calculation
                                
                                
            Else 'Change formating of unowned programs
                Range(Cells(Srow, 1), Cells(Srow, 8)).Select
                With Selection
                    .Interior.Color = RGB(230, 184, 183)
                End With
                Range(Cells(Srow, 1), Cells(Srow, 2)).ClearContents
            End If
                        
        Else 'Change formating of Completed Rows
            Range(Cells(Srow, 1), Cells(Srow, 8)).Select
            With Selection
                .Interior.Color = RGB(216, 228, 188)
            End With
            Range(Cells(Srow, 1), Cells(Srow, 2)).ClearContents
        End If
            
    Srow = Srow + 1
    Loop
    
    'Sort data based on column B, then column C:This was from a recorded macro
    
    Columns("B:I").Select
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("B2:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveSheet.Sort.SortFields.Add Key:=Range("C2:C"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range("B:I")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
End Sub


'Set Case for determining Type points
Sub wTypePoints()
    
    Const STRENGTH = 0
    Const MIXED = 5
    Const MARTIALARTS = 10
    Const CARDIO = 15
    Const DANCE = 20
    wType = ActiveSheet.Cells(Srow, 5).Value
    
    Select Case wType
        Case Is = "Strength"
            wTypept = STRENGTH
        Case Is = "Mixed"
            wTypept = MIXED
        Case Is = "Martial Arts"
            wTypept = MARTIALARTS
        Case Is = "Cardio"
            wTypept = CARDIO
        Case Is = "Dance"
            wTypept = DANCE
    End Select
End Sub


'Set case for determining Difficulty points
Sub wDifficultyPoints()


    Const BEGINNER = 0
    Const BEGINNERINTERMEDIATE = 5
    Const INTERMEDIATE = 10
    Const INTERMEDIATEADVANCED = 15
    Const ADVANCED = 20
    Const EXPERT = 25
    wDifficulty = ActiveSheet.Cells(Srow, 6).Value
    
     Select Case wDifficulty
        Case Is = "Beginner"
            wDifficultypt = BEGINNER
        Case Is = "Beginner/Intermediate"
            wDifficultypt = BEGINNERINTERMEDIATE
        Case Is = "Intermediate"
            wDifficultypt = INTERMEDIATE
        Case Is = "Intermediate/Advanced"
            wDifficultypt = INTERMEDIATEADVANCED
        Case Is = "Advanced"
            wDifficultypt = ADVANCED
        Case Is = "Expert"
            wDifficultypt = EXPERT
    End Select
End Sub


'Set case for determining Desireability Points
Sub wDesirePoints()


    Const LOW = 20
    Const MEDIUM = 10
    Const HIGH = 0
    wDesire = ActiveSheet.Cells(Srow, 7).Value
    
    Select Case wDesirept
        Case Is = "Low"
            wDesirept = LOW
        Case Is = "Medium"
            wDesirept = MEDIUM
        Case Is = "High"
            wDesirept = HIGH
    End Select
End Sub
 
I have gotten everything to work as far as calculating the values and entering it in the correct cell.

The next issue that I am having I assume is coming from the sorting process I want to sort the data based on the value in Column B and then Alphabetically by Column C.

What happens is that the data first arranges column b and the resorts by column c so then the point values get unassociated with their values. Each time I click the command button then the value column remains the same but the other columns all change sequence, how can i get this to sort so that each row moves together during the sorting process.

Below is my code for the sorting

Code: 
Columns("A:I").Select    
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveSheet.Sort.SortFields.Add Key:=Range("C:C"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Priorities").Sort
        .SetRange Range("A:I")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
Update: Get unique values

Thanks to those who helped me. I am now trying to get the unique values of the priority values. My code is below

What i want it to read is if column A contains text then copy only the unique values to K2 otherwise do nothing.

The code below gives an error message. If I remove the if statement then it also copies the empty cells that have no value but conditional formatting that was defined earlier in the code.

Code: 
Sub GetUnique()

    If ActiveSheet.Range("A2:A").Value > 0 Then
        ActiveSheet.Range("A2:A").AdvancedFilter Action:=xlFilterCopy, Copytorange:=ActiveSheet.Range("K2"), Unique:=True
    End If
       
End Sub
 
This will fix the original problem - the button did nothing because the event was named incorrectly - N.B.:


Code: 
Private Sub cmdPriority_Click()
Prioritize
End Sub

Private Sub Prioritize(): Dim r As Long
    For r = 2 To Range("C" & Rows.Count).End(xlUp).Row
      
    If Range("C" & r).Value <> "" Then
        If Range("H" & r).Value = "No" Then
            If Range("G" & r).Value = "Yes" Then
                
 Range("B" & r).Value = wTypePts(Range("E" & r)) + _
wDifficultyPts(Range("F" & r)) + Val(Left(Range("D" & r), 3))
            Else
                Range("B" & r).Value = ""
            End If
        Else
            Range("B" & r).Value = ""
        End If
    End If
    Next r
End Sub

'Set points for Workout Type


Private Function wTypePts(wtype As String) As Long
     
    Select Case wtype
        Case Is = "Strength"
            wTypePts = STRENGTH
        Case Is = "Mixed"
            wTypePts = MIXED
        Case Is = "Martial Arts"
            wTypePts = MARTIALARTS
        Case Is = "Cardio"
            wTypePts = CARDIO
        Case Is = "Dance"
            wTypePts = DANCE
    End Select
End Function


'Set points for Difficulty


Private Function wDifficultyPts(wdiffPt As String) As Long
     
    Select Case wdiffPt
        Case Is = "Beginner"
            wDifficultyPts = BEGINNER
        Case Is = "Beginner/Intermediate"
            wDifficultyPts = BEGINNERINTERMEDIATE
        Case Is = "Intermediate"
            wDifficultyPts = INTERMEDIATE
        Case Is = "Intermediate/Advanced"
            wDifficultyPts = INTERMEDIATEADVANCED
        Case Is = "Advanced"
            wDifficultyPts = ADVANCED
        Case Is = "Expert"
            wDifficultyPts = EXPERT
    End Select
End Function
 
Thanks. I discovered that yesterday and have since moved to the next tasks
 
You must log in or register to reply here.
Back
Top