Find Trimmed Mean of all the values of an item

[Oraekene]

Hi. Stumped on this for a while. I would like to find all the values of an item in a range like a sort of index-match, then find the trimmed mean of those values, and repeat this process for each of the other items in the range. Attached is a sample sheet showing what i would like. Would be grateful for any help on this https://fastupload.io/en/GQ1tRM9vgziJedr/file

 

[Oraekene]

Can't seem to edit or delete my post. This is the working link for the sample sheet here xlsx: TRIMMEAN SAMPLE DATASHEET.xlsx

 

[Fluff]

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: Find Trimmed Mean of all the values of an item
and here Find Trimmed Mean of all the values of an item

If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.

 

[Alex Blakenburg]

Give this a try.

Update the 3 lines that have comments that look like this ' <---

Sub SumUniqueItems()

    Dim rngAnalysis As Range, arrAnalysis As Variant
    Dim shtAnalysis As Worksheet, shtReport As Worksheet
    Dim rngReport As Range
    Dim lrowAnalysis As Long, i As Long, j As Long
    Dim dictAnalysis As Object, dictKey As String
    Dim dKey As Variant
    Dim arrSplit As Variant
    Dim arrOut() As Double
    Dim TrimMeanPercent As Single
    
    TrimMeanPercent = 0.2                                           ' <--- Note 20% takes 10% off the top and 10% off the bottom
    
    Set shtAnalysis = Worksheets("analysis3")                       ' <--- Change to data source sheet name
    With shtAnalysis.Range("C1").CurrentRegion
        Set rngAnalysis = .Offset(1).Resize(.Rows.Count - 1)
    End With
    arrAnalysis = rngAnalysis.Value

    Set shtReport = Worksheets("report3")                           ' <--- Change to output sheet name
    Set rngReport = shtReport.Range("A2")

    Set dictAnalysis = CreateObject("Scripting.dictionary")
    
    ' Load Analysis range into Dictionary & Concatenate the Values
    For i = 1 To UBound(arrAnalysis) Step 1
        For j = 1 To UBound(arrAnalysis, 2) Step 2
            If arrAnalysis(i, j) <> "" Then
                dictKey = arrAnalysis(i, j)
                If Not dictAnalysis.exists(dictKey) Then
                    dictAnalysis(dictKey) = arrAnalysis(i, j + 1)
                Else
                     dictAnalysis(dictKey) = dictAnalysis(dictKey) & "," & arrAnalysis(i, j + 1)
                End If
            End If
        Next j
    Next i
   
    For Each dKey In dictAnalysis.keys
        arrSplit = Split(dictAnalysis(dKey), ",")
        ReDim arrOut(1 To UBound(arrSplit) + 1, 1 To 1)
        For i = 0 To UBound(arrSplit)
            arrOut(i + 1, 1) = arrSplit(i)
        Next i
        dictAnalysis(dKey) = Application.TrimMean(arrOut, TrimMeanPercent)
    Next dKey
    ' Write back Totals
    rngReport.CurrentRegion.Offset(1).ClearContents
    rngReport.Resize(dictAnalysis.Count).Value = Application.Transpose(dictAnalysis.keys)
    rngReport.Resize(dictAnalysis.Count).Offset(0, 1).Value = Application.Transpose(dictAnalysis.items)

End Sub

 

[Oraekene]

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: Find Trimmed Mean of all the values of an item
and here Find Trimmed Mean of all the values of an item

If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.

Thank you for this. I apologise, i am still new to forum rules. Below are the other forums where its been posted


1. Find Trimmed Mean of all the values of an item
2. Find Trimmed Mean of all the values of an item/
3. Find Trimmed Mean of all the values of an item
4. Find Trimmed Mean of all the values of an item/
5. Redit
6. Find Trimmed Mean of all the values of an item

 

[Oraekene]

Give this a try.

Update the 3 lines that have comments that look like this ' <---

Sub SumUniqueItems()

    Dim rngAnalysis As Range, arrAnalysis As Variant
    Dim shtAnalysis As Worksheet, shtReport As Worksheet
    Dim rngReport As Range
    Dim lrowAnalysis As Long, i As Long, j As Long
    Dim dictAnalysis As Object, dictKey As String
    Dim dKey As Variant
    Dim arrSplit As Variant
    Dim arrOut() As Double
    Dim TrimMeanPercent As Single
    
    TrimMeanPercent = 0.2                                           ' <--- Note 20% takes 10% off the top and 10% off the bottom
    
    Set shtAnalysis = Worksheets("analysis3")                       ' <--- Change to data source sheet name
    With shtAnalysis.Range("C1").CurrentRegion
        Set rngAnalysis = .Offset(1).Resize(.Rows.Count - 1)
    End With
    arrAnalysis = rngAnalysis.Value

    Set shtReport = Worksheets("report3")                           ' <--- Change to output sheet name
    Set rngReport = shtReport.Range("A2")

    Set dictAnalysis = CreateObject("Scripting.dictionary")
    
    ' Load Analysis range into Dictionary & Concatenate the Values
    For i = 1 To UBound(arrAnalysis) Step 1
        For j = 1 To UBound(arrAnalysis, 2) Step 2
            If arrAnalysis(i, j) <> "" Then
                dictKey = arrAnalysis(i, j)
                If Not dictAnalysis.exists(dictKey) Then
                    dictAnalysis(dictKey) = arrAnalysis(i, j + 1)
                Else
                     dictAnalysis(dictKey) = dictAnalysis(dictKey) & "," & arrAnalysis(i, j + 1)
                End If
            End If
        Next j
    Next i
   
    For Each dKey In dictAnalysis.keys
        arrSplit = Split(dictAnalysis(dKey), ",")
        ReDim arrOut(1 To UBound(arrSplit) + 1, 1 To 1)
        For i = 0 To UBound(arrSplit)
            arrOut(i + 1, 1) = arrSplit(i)
        Next i
        dictAnalysis(dKey) = Application.TrimMean(arrOut, TrimMeanPercent)
    Next dKey
    ' Write back Totals
    rngReport.CurrentRegion.Offset(1).ClearContents
    rngReport.Resize(dictAnalysis.Count).Value = Application.Transpose(dictAnalysis.keys)
    rngReport.Resize(dictAnalysis.Count).Offset(0, 1).Value = Application.Transpose(dictAnalysis.items)

End Sub

Thank you for this! Thank you for always responding. I will try this out and share my result. Again, thank you!

 

[Oraekene]

Give this a try.

Update the 3 lines that have comments that look like this ' <---

Sub SumUniqueItems()

    Dim rngAnalysis As Range, arrAnalysis As Variant
    Dim shtAnalysis As Worksheet, shtReport As Worksheet
    Dim rngReport As Range
    Dim lrowAnalysis As Long, i As Long, j As Long
    Dim dictAnalysis As Object, dictKey As String
    Dim dKey As Variant
    Dim arrSplit As Variant
    Dim arrOut() As Double
    Dim TrimMeanPercent As Single
    
    TrimMeanPercent = 0.2                                           ' <--- Note 20% takes 10% off the top and 10% off the bottom
    
    Set shtAnalysis = Worksheets("analysis3")                       ' <--- Change to data source sheet name
    With shtAnalysis.Range("C1").CurrentRegion
        Set rngAnalysis = .Offset(1).Resize(.Rows.Count - 1)
    End With
    arrAnalysis = rngAnalysis.Value

    Set shtReport = Worksheets("report3")                           ' <--- Change to output sheet name
    Set rngReport = shtReport.Range("A2")

    Set dictAnalysis = CreateObject("Scripting.dictionary")
    
    ' Load Analysis range into Dictionary & Concatenate the Values
    For i = 1 To UBound(arrAnalysis) Step 1
        For j = 1 To UBound(arrAnalysis, 2) Step 2
            If arrAnalysis(i, j) <> "" Then
                dictKey = arrAnalysis(i, j)
                If Not dictAnalysis.exists(dictKey) Then
                    dictAnalysis(dictKey) = arrAnalysis(i, j + 1)
                Else
                     dictAnalysis(dictKey) = dictAnalysis(dictKey) & "," & arrAnalysis(i, j + 1)
                End If
            End If
        Next j
    Next i
   
    For Each dKey In dictAnalysis.keys
        arrSplit = Split(dictAnalysis(dKey), ",")
        ReDim arrOut(1 To UBound(arrSplit) + 1, 1 To 1)
        For i = 0 To UBound(arrSplit)
            arrOut(i + 1, 1) = arrSplit(i)
        Next i
        dictAnalysis(dKey) = Application.TrimMean(arrOut, TrimMeanPercent)
    Next dKey
    ' Write back Totals
    rngReport.CurrentRegion.Offset(1).ClearContents
    rngReport.Resize(dictAnalysis.Count).Value = Application.Transpose(dictAnalysis.keys)
    rngReport.Resize(dictAnalysis.Count).Offset(0, 1).Value = Application.Transpose(dictAnalysis.items)

End Sub

Holy ****! Holy **** it works! Alex you arw a genius! How did you do this? And the notes you leave behind are so helpful! I need to learn Arrays from you! Thank you!!!

 

[Alex Blakenburg]

You're welcome. Glad I could help.

 

[Oraekene]

You're welcome. Glad I could help.

Hi alex! Was able to complete the previous project i was working on thanks to your help! I need your help on a new challenge again. Please check this out Thread 'VBA Loop Lookup of every nth (eg. every 3rd) match of an item' VBA Loop Lookup of every nth (eg. every 3rd) match of an item i think it might use some sort of looped vlookup but i think vlookup usually shows only the first entry and doesn't loop every nth time on the same lookup value, that's where i'm stumped. Would really appreciate your help