MS Forms Excel VBA Class Calculate ranged values
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ResponseSummary"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Option Compare Text
Public ResponsesFoundCount As Integer ''responses in prioritization list
Public ResponsesFound As New Collection ''Responses possible in condiseration
Public ResponseCount As Integer ''number of responses added to the check
Private RPC() As Integer ''RPC array of responses and their relative positions
Private ResponseSourceMaxLen As Integer ''maximum lenght of response
Private Sub Class_Initialize()
Set ResponsesFound = New Collection ''initialize collection
End Sub
Private Function pad3(str As String) As String
pad3 = Right("000" & str, 3) & "|"
End Function
Property Set SourceRange(source As Range)
Dim item As Variant ''iterate list
Dim found As Boolean ''if already in list
Dim x As Variant ''For split
Dim xi As Integer ''iterate x
Dim i As Integer 'iterate source rows
''gather references from prioritization
For i = 1 To source.Rows.Count
x = Split(source.Cells(i, 1), ";") ''not assuming all values are in every case
For xi = LBound(x) To UBound(x)
For Each item In ResponsesFound
If LCase(Trim(x(xi))) = LCase(Trim(item)) Then
found = True
Exit For
End If
Next item
If Not found And Trim(x(xi)) > "" Then
ResponsesFound.Add Trim(x(xi))
End If
found = False
Next xi
Next i
ResponsesFoundCount = ResponsesFound.Count
ReDim RPC(1 To ResponsesFoundCount, 1 To ResponsesFoundCount)
''then iterate source to count
For i = 1 To source.Rows.Count ''for each response
Me.AddResponse source.Cells(i, 1).Value
Next i
End Property
''Add responses from ME.source(i,1) or from external add(Manual coding)
Function AddResponse(strResponse As String)
Dim i As Integer ''counter
Dim x As Variant ''split
Dim xi As Integer ''iterate x() elements
If InStr(1, strResponse, ";") = 0 Then
Err.Raise -1, , "Missing Semicolon separated responses"
Exit Function
End If
ResponseCount = ResponseCount + 1 ''add to total response count
''take one response and count up positions
x = Split(strResponse, ";")
For xi = LBound(x) To UBound(x)
''find corresponding RPC to add
If x(xi) > "" Then
For i = 1 To ResponsesFoundCount
''Stop
If Trim(LCase(ResponsesFound.item(i))) = Trim(LCase(x(xi))) _
Then
''add 1 to RPC
RPC(i, xi + 1) = RPC(i, xi + 1) + 1
Exit For
End If
Next i
End If
Next xi
End Function
Function Position_TTLs() As String
Dim i As Integer, ii As Integer
Dim strout As String
strout = ""
For i = 1 To ResponsesFoundCount ''Response sources for prioritization
For ii = 1 To ResponsesFoundCount
strout = strout & pad3("" & RPC(i, ii))
Next ii
strout = strout & ResponsesFound(i) & vbLf
Next i
strout = LFSort(strout)
'''HEADER
Dim hdr As String
For i = 1 To ResponsesFoundCount ''Response sources for prioritization
hdr = hdr & pad3("" & i)
Next i
hdr = hdr & " <<- Priority of Count of " & ResponsesFoundCount & " possible priorities." _
& vbLf ''title line wrap
strout = hdr & strout
''clean reduntand chars CRLF, LF, CR last row:
Do While Right(strout, 1) < Chr(32) And Len(Right(strout, 1)) > 1
strout = Left(strout, Len(strout) - 1)
Loop
Position_TTLs = strout
End Function
Function WeightedPercentileByPositions100Pct() As String
''Chat GPT 3.5 https://chat.openai.com/share/ba5b81e6-1bb2-4560-ad50-5630eefe19b5
Dim i As Integer
Dim j As Integer
Dim totalResponses As Double
Dim responseScores As Collection
Dim responseScore As Double
Dim responsePercentiles As String
' Initialize the collection to store response scores
Set responseScores = New Collection
' Calculate the total number of responses
For i = 1 To ResponsesFoundCount
totalResponses = totalResponses + ResponseCount ' Assuming total response count
Next i
' Calculate the weighted score for each response based on all positions
For i = 1 To ResponsesFoundCount
responseScore = 0
For j = 1 To ResponsesFoundCount
responseScore = responseScore + (ResponsesFoundCount - j + 1) * RPC(i, j)
Next j
' Calculate the weighted percentile based on positions
Dim weightedPercentile As Double
If totalResponses > 0 Then
weightedPercentile = (responseScore / totalResponses) * 100
' Ensure the percentile is within the range [0, 100]
weightedPercentile = Application.WorksheetFunction.Min(100, Application.WorksheetFunction.Max(0, weightedPercentile))
Else
' Handle division by zero or empty response set
weightedPercentile = 0
End If
' Add the response and its percentile to the collection
responseScores.Add responseScore
responsePercentiles = responsePercentiles & Format(weightedPercentile, "00") & "% : " & ResponsesFound(i) & vbLf
Next i
''clean reduntand chars CRLF, LF, CR last row:
Do While Right(responsePercentiles, 1) < Chr(32) And Len(Right(responsePercentiles, 1)) > 1
responsePercentiles = Left(responsePercentiles, Len(responsePercentiles) - 1)
Loop
responsePercentiles = LFSort(responsePercentiles)
''Add header
responsePercentiles = "##%: Calculate Weighted Percentile By Positions 100Pct" & vbLf & responsePercentiles
' Return a string containing all response percentiles
WeightedPercentileByPositions100Pct = responsePercentiles
End Function
Function WeightedPercentileByPositionsN_2() As String
''https://chat.openai.com/share/ba5b81e6-1bb2-4560-ad50-5630eefe19b5
Dim i As Integer
Dim j As Integer
Dim responseScores As Collection
Dim responseScore As Double
Dim responsePercentiles As String
' Initialize the collection to store response scores
Set responseScores = New Collection
' Calculate the weighted score for each response based on all positions
For i = 1 To ResponsesFoundCount
responseScore = 0
For j = 1 To ResponsesFoundCount
' Adjust the weighting scheme here
responseScore = responseScore + (ResponsesFoundCount - j + 1) ^ 2 * RPC(i, j)
Next j
' Add the response and its weighted score to the collection
responseScores.Add responseScore
Next i
' Calculate the total number of points
Dim totalPoints As Double
For i = 1 To ResponsesFoundCount
totalPoints = totalPoints + responseScores(i)
Next i
' Calculate the weighted percentile for each response based on total points
For i = 1 To ResponsesFoundCount
Dim weightedPercentile As Double
If totalPoints > 0 Then
weightedPercentile = (responseScores(i) / totalPoints) * 100
' Ensure the percentile is within the range [0, 100]
weightedPercentile = Application.WorksheetFunction.Min(100, Application.WorksheetFunction.Max(0, weightedPercentile))
Else
' Handle division by zero or empty response set
weightedPercentile = 0
End If
' Add the response and its percentile to the string
responsePercentiles = responsePercentiles & Format(weightedPercentile, "00") & "% : " & ResponsesFound(i) & " " & vbLf
Next i
' Clean redundant characters CRLF, LF, CR last row:
Do While Asc(Right(responsePercentiles, 1)) < 32 And Len(Right(responsePercentiles, 1)) > 1
responsePercentiles = Left(responsePercentiles, Len(responsePercentiles) - 1)
Loop
responsePercentiles = LFSort(responsePercentiles)
' Add header
responsePercentiles = "##%: Weighted Percentile By Positions (n)^2" & vbLf & responsePercentiles
' Return a string containing all response percentiles
WeightedPercentileByPositionsN_2 = responsePercentiles
End Function
Function WeightedPercentileByPositions_N_Minus1_2() As String
''https://chat.openai.com/share/ba5b81e6-1bb2-4560-ad50-5630eefe19b5
Dim i As Integer
Dim j As Integer
Dim responseScores As Collection
Dim responseScore As Double
Dim responsePercentiles As String
' Initialize the collection to store response scores
Set responseScores = New Collection
' Calculate the weighted score for each response based on all positions
For i = 1 To ResponsesFoundCount
responseScore = 0
For j = 1 To ResponsesFoundCount
' Adjust the weighting scheme here
responseScore = responseScore + (ResponsesFoundCount - j - 1) ^ 2 * RPC(i, j)
Next j
' Add the response and its weighted score to the collection
responseScores.Add responseScore
Next i
' Calculate the total number of points
Dim totalPoints As Double
For i = 1 To ResponsesFoundCount
totalPoints = totalPoints + responseScores(i)
Next i
' Calculate the weighted percentile for each response based on total points
For i = 1 To ResponsesFoundCount
Dim weightedPercentile As Double
If totalPoints > 0 Then
weightedPercentile = (responseScores(i) / totalPoints) * 100
' Ensure the percentile is within the range [0, 100]
weightedPercentile = Application.WorksheetFunction.Min(100, Application.WorksheetFunction.Max(0, weightedPercentile))
Else
' Handle division by zero or empty response set
weightedPercentile = 0
End If
' Add the response and its percentile to the string
responsePercentiles = responsePercentiles & Format(weightedPercentile, "00") & "% : " & ResponsesFound(i) & " " & vbLf
Next i
' Clean redundant characters CRLF, LF, CR last row:
Do While Asc(Right(responsePercentiles, 1)) < 32 And Len(Right(responsePercentiles, 1)) > 1
responsePercentiles = Left(responsePercentiles, Len(responsePercentiles) - 1)
Loop
responsePercentiles = LFSort(responsePercentiles)
' Add header
responsePercentiles = "##%: Weighted Percentile By Positions ((n-1)^2)" & vbLf & responsePercentiles
' Return a string containing all response percentiles
WeightedPercentileByPositions_N_Minus1_2 = responsePercentiles
End Function
''breaks on LF ans sorts largest to smallest
Private Function LFSort(strString As String) As String
''sorts values based on LF
Dim x
Dim i As Integer, j As Integer, tmp As String
x = Split(strString, vbLf)
If x(UBound(x)) = "" Then ReDim Preserve x(UBound(x) - 1) ''Remove added null at end
For i = LBound(x) To UBound(x) - 1
For j = i + 1 To UBound(x)
If x(j) > x(i) Then
tmp = x(i)
x(i) = x(j)
x(j) = tmp
End If
Next j
Next i
For i = LBound(x) To UBound(x)
LFSort = LFSort & x(i) & vbLf
Next i
End Function
''--------------------------------------------------------------------------------------
Attribute VB_Name = "FormsSummaries"
Option Explicit
Option Compare Text
Function Position_TTLs(source As Range) As String
''gather up all types in column based on splitting and ID'ing unique values from ";"
''Count up the respectie positions
''return the weighted numbers as a CHR(10) List
''Option to return weighted numbers as percentages against a 12345 or 1248 weighted scale
Dim response As New ResponseSummary
Set response.SourceRange = source ''use source range to set repsonses
Position_TTLs = response.Position_TTLs()
End Function
Function Weighted_Percentile_By_Positions_100Pct(source As Range) As String
''gather up all types in column based on splitting and ID'ing unique values from ";"
''Count up the respectie positions
''return the weighted numbers as a CHR(10) List
''Option to return weighted numbers as percentages against a 12345 or 1248 weighted scale
Dim response As New ResponseSummary
Set response.SourceRange = source ''use source range to set repsonses
Weighted_Percentile_By_Positions_100Pct = response.WeightedPercentileByPositions100Pct()
End Function
Function WeightedPercentileByPositions_N_Minus1_2(source As Range) As String
''gather up all types in column based on splitting and ID'ing unique values from ";"
''Count up the respectie positions
''return the weighted numbers as a CHR(10) List
''Option to return weighted numbers as percentages against a 12345 or 1248 weighted scale
Dim response As New ResponseSummary
Set response.SourceRange = source ''use source range to set repsonses
WeightedPercentileByPositions_N_Minus1_2 = response.WeightedPercentileByPositions_N_Minus1_2()
End Function
Function Weighted_Percentile_By_Positions_N_2(source As Range) As String
''gather up all types in column based on splitting and ID'ing unique values from ";"
''Count up the respectie positions
''return the weighted numbers as a CHR(10) List
''Option to return weighted numbers as percentages against a 12345 or 1248 weighted scale
Dim response As New ResponseSummary
Set response.SourceRange = source ''use source range to set repsonses
Weighted_Percentile_By_Positions_N_2 = response.WeightedPercentileByPositionsN_2()
End Function
Comments
Post a Comment