Display same amount of values when narrowing a column

[crowds40]

Hi,

I hope my question isn't too complicated. So say in my column A I have:

blue
red
green
yellow
green
yellow
yellow
blue
...

Say in the end I have:
50 blue, 20 red, 100 green, and 180 yellow

If I am narrowing down the my amount of rows to just 100. How do I make it:
27 blue, 20 red, 27 green, 27 yellow
(I understand this is 101 which is fine or it could be 26 blue, 20 red, 27 green, 27 yellow so it uses the highest amounts to make it 100 if its easier to make a formula or macro)

Note that these amount will change each time I use excel. So next time I could start with:
15 blue, 30 red, 120 green, 200 yellow.

Again narrowing the amount to 100:
15 blue, 28 red, 28 green, 28 yellow (this equals 99, but to be 100 it could be 15 blue, 28 red, 28 green, 29 yellow)

So I would need a formula or macro which could display the same amount of colors, even if one of the colors is less then the average, to equal 100 total colors.
I hope this makes sense. I can try to explain further. Please help. Thank you.

 

[BiocideJ]

I'm not entirely sure this is exactly what you are looking for and I'm struggling with the purpose of this, but it was an interesting exercise.

In cells C2:C5 the colors (blue, red, green, yellow)
In Cell D2 and dragged down to D5 enter: =COUNTIF(A:A,C2)
In Cell E2 and dragged down to E5 enter: =IF(D2<100/COUNTA($C$2:$C$99),D2,ROUND((100-SUMIF($D$2:$D$99,"<"&100/COUNTA($C$2:$C$99)))/COUNTIF($D$2:$D$99,">=" &100/COUNTA($C$2:$C$99)),0))

Allowances:
- This formula allows for rounding errors (so it will sometimes give numbers slightly more or less than 100 [these variances will increase if more unique colors are added])
- This formula does allow for additional colors to be entered in column C (down to C99) and the formula will automatically compensate.
- This formula does NOT consider colors in column A which do not appear in column C.

 

[crowds40]

Hi BiocideJ,

Thanks for the quick response. Your formulas work well for the number of colors (https://ibb.co/bOOTuJ) and close to what I want. What I would like it to do is actually show all the rows with the colors. So if you look at the image I provided I would like column E to have the 19 rows of blue, then 27 red, 27 green, 27 yellow and they don't have to in order. But the problem is I would need the full row to be copied with the color.

Here is what my excel file looks like (https://ibb.co/emuyTd). So it will have 1000's of rows. What you have provided is actually good because after using your formula I can go to filter and delete to the right amount of colors and maybe create a macro from it but I wouldn't know how to make the macro delete the correct amount of colors for each excel file because they will all have different amount of colors.

Again I know this might be confusing but hopefully it is starting to make more sense. Any ideas. Your help has been great so far.

 

[BiocideJ]

Alright. This was a bit fun.

I made it very dynamic so if your needs change in the future, this code should be able to adapt to those needs.
The code operates on a somewhat similar methodology to the formula calculations (however, you no longer need to keep those calculations in the sheet as this macro is fully self-contained)
There is a section towards the top that will allow/require you to make some changes. (specifically, you will need to change Sheet1 to whatever your actual sheet is)
**
Also, you will need to set a reference to Microsoft Scripting Runtime by using Tools > References in the Visual Basic Editor

Option Explicit


Sub CondenseToNrows()


Dim dctC As Scripting.Dictionary
Dim arrN As Variant
Dim ws As Worksheet
Dim rngC As Range
Dim n As Long, i As Long
Dim runningN As Long, runningC As Long


    Set dctC = New Dictionary




'**** EDIT BELOW LINE(S)
    n = 100                     'this is the number of final rows the export should be condensed to (in case it changes later)
    Set ws = Sheets("Sheet1")   'change the name of Sheet1 to the name of the sheet with the colors in column A
    'dctC is a scripting dictionary where the key is the color and the value is the number of times it appears in the initial list.
    dctC.Add "red", 0
    dctC.Add "yellow", 0
    dctC.Add "blue", 0
    dctC.Add "green", 0
'*** DO NOT EDIT BELOW THIS LINE
  
'count what exists
    For Each rngC In ws.Range("A1:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
        If dctC.Exists(rngC.Value) Then
            dctC(rngC.Value) = dctC(rngC.Value) + 1
        End If
    Next rngC


'determine how many of each item to include to reach N items


    'create array to hold final row counts to show
    ReDim arrN(0 To dctC.Count - 1, 0 To 1)
    For i = 0 To dctC.Count - 1
        arrN(i, 0) = dctC.Keys(i)
        arrN(i, 1) = 0
    Next i
    
    'determine # of rows to show (for items < n/count)
    For i = LBound(arrN) To UBound(arrN)
        If dctC(arrN(i, 0)) < n / dctC.Count Then
            arrN(i, 1) = dctC(arrN(i, 0))
            runningN = runningN + arrN(i, 1)    'running sum of values under average
            runningC = runningC + 1             'running count of values under average
        End If
    Next i
    
    'determine # of rows to show (for items >= n/count)
    For i = LBound(arrN) To UBound(arrN)
        If dctC(arrN(i, 0)) >= n / dctC.Count Then
            arrN(i, 1) = WorksheetFunction.Round((n - runningN) / (dctC.Count - runningC), 0)
        End If
    Next i
    
    'write array variables back to dictionary
    For i = LBound(arrN) To UBound(arrN)
        dctC(arrN(i, 0)) = arrN(i, 1)
        Debug.Print arrN(i, 0) & ": " & arrN(i, 1)
    Next i
    
    ws.Rows.EntireRow.Hidden = False    'unhide all to begin
    'iterate through rows decrementing the item counts until the necessary number of rows are unhidden.
    For Each rngC In ws.Range("A1:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
        If dctC.Exists(rngC.Value) Then
            If dctC(rngC.Value) > 0 Then
                dctC(rngC.Value) = dctC(rngC.Value) - 1
            Else
                rngC.EntireRow.Hidden = True
            End If
        End If
    Next rngC


    
End Sub

 

[crowds40]

Thanks so much for taking the time to write the code and help again BiocideJ. I am sure your code will work but the problem is I use excel on a Mac so I believe it doesn't have "Microsoft Scripting Runtime." After researching a bit people are saying using "Collection" is similar to "Dictionary." I am not sure if it will work with your code or if I need to implement a way to allow Mac excel to use Dictionary. Is there another way to use without Dictionary?

 

[BiocideJ]

I remembered why I prefer using Dictionaries.
Collections wouldn't serve the purpose I am working with here unfortunately because you can't edit the values as easily.
Instead I just went to a complete array-based code so you should be good now.

Option Explicit




Sub CondenseToNrows()




Dim arrC As Variant
Dim arrN As Variant
Dim ws As Worksheet
Dim rngC As Range
Dim n As Long, i As Long
Dim runningN As Long, runningC As Long




'**** EDIT BELOW LINE(S)
    n = 100                     'this is the number of final rows the export should be condensed to (in case it changes later)
    Set ws = Sheets("Sheet1")   'change the name of Sheet1 to the name of the sheet with the colors in column A
    'arrC is an array where the first column is the color and the 2nd column is the number of times it appears in the initial list.
    arrC = [{"red",0; "yellow",0; "blue",0; "green",0}]    'create the array (use ; to seperate colors[rows])


'*** DO NOT EDIT BELOW THIS LINE
    
    arrN = arrC
'count what exists
    For Each rngC In ws.Range("A1:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
        IncMyArray arrC, rngC.Value, 1  'adds one to the array item for the corresponding color on each row
    Next rngC




'determine how many of each item to include to reach N items


    'determine # of rows to show (for items < n/count)
    For i = LBound(arrN) To UBound(arrN)
        If arrC(i, LBound(arrC, 2)) < n / (UBound(arrC) - LBound(arrC) + 1) Then
            arrN(i, 1) = arrC(i, LBound(arrC, 2))
            runningN = runningN + arrN(i, 1)    'running sum of values under average
            runningC = runningC + 1             'running count of values under average
        End If
    Next i
    
    'determine # of rows to show (for items >= n/count)
    For i = LBound(arrN) To UBound(arrN)
        If arrC(i, LBound(arrC, 2)) >= n / (UBound(arrC) - LBound(arrC) + 1) Then
            arrN(i, UBound(arrC, 2)) = WorksheetFunction.Round((n - runningN) / ((UBound(arrC) - LBound(arrC) + 1) - runningC), 0)
        End If
    Next i
    
    'write array variables back to iniitial array
    For i = LBound(arrN) To UBound(arrN)
        arrC(i, UBound(arrC, 2)) = arrN(i, UBound(arrN, 2))


    Next i
    
    ws.Rows.EntireRow.Hidden = False    'unhide all to begin
    'iterate through rows decrementing the item counts until the necessary number of rows are unhidden.
    For Each rngC In ws.Range("A1:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
        If IncMyArray(arrC, rngC.Value) > 0 Then
            IncMyArray arrC, rngC.Value, -1 'decrement array item
            
        ElseIf IncMyArray(arrC, rngC.Value) = 0 Then
            rngC.EntireRow.Hidden = True
            
        Else
            'color is not in array (leave row visible)
        End If
    Next rngC


    
End Sub


Public Function IncMyArray(a As Variant, cKey As String, Optional inc As Long = 0) As Long
'adds inc to the array (a) where the first column matches cKey and returns the new value
'if inc is excluded (or passed in as 0) then this will functionally just return the current value associated with cKey
Dim i As Long


IncMyArray = -1
    'this is a custom function and it is known the color will be in the first 'column' of the array
    For i = LBound(a) To UBound(a)
        
        If a(i, LBound(a, 2)) = cKey Then
            a(i, UBound(a, 2)) = a(i, UBound(a, 2)) + inc
            IncMyArray = a(i, UBound(a, 2))
            Exit Function
        End If
        
    Next i
End Function

 

[crowds40]

I tried but couldn't seem to get it to work. I had all my colors in Sheet1 column A and random "test" value in columns B,C,D,E (https://ibb.co/mjzKpT) to see if they would carry over. I opened Sheet2 to use the macro which is what I am suppose to do right? After running the macro it would just leave a blank Sheet2.

I then added a semicolon at the end of "green",0 in the arrC which I have no idea if I was suppose to or not. So from:
arrC = [{"red",0; "yellow",0; "blue",0; "green",0}]
->
arrC = [{"red",0; "yellow",0; "blue",0; "green",0;}]

I would get Run-time error "13" (https://ibb.co/heAyio). I debugged it and said the error is here (https://ibb.co/dg3OG8). Again I have no idea if I was suppose to put that semicolon in or not or maybe I did the macro wrong and on the wrong Sheet. You got it to work on your end? Let me know if I did something wrong. Thanks again.

 

[BiocideJ]

There shouldn't need to be a ; after green.
the supplied code would be sufficient for your initial 4 colors.
arrC = [{"red",0; "yellow",0; "blue",0; "green",0}]

I only mentioned the semicolon addition because if, in the future, you decided to add (say) orange, you could do that by adding a semicolon between green, 0 and orange, 0 as so:
arrC = [{"red",0; "yellow",0; "blue",0; "green",0; "orange", 0}]

Assuming your data was actually in Sheet1, you wouldn't need to change anything from the code supplied.

 

[BiocideJ]

Also, I wonder if there is another difference between how MAC vs PC VBA is determining variant types. Try changing the following (additions are in red)

...
Dim arrC() As Variant
Dim arrN() As Variant
Dim ws As Worksheet
Dim rngC As Range

.
.
.

Public Function IncMyArray(a() As Variant, cKey As String, Optional inc As Long = 0) As Long
...

That should help reiterate that the Variants are actually Arrays and possibly avoid any confusion at run-time.

 

[crowds40]

I tried with adding the all the additions in red and it was same as the original. I click to run the macro and I guess it runs because there are no errors but nothing happens. It just stays a blank Sheet2 (again assuming that is the right way to do it where my colors are in Sheet1 column A and I open a new sheet (Sheet2) to run the macro)