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