VBA Programming help

Shoeboxken · Nov 18, 2017

I would like to use a VBA coding to create a list of information pulled from a data set.

Data would include the following info as examples:
Type Number Name
Bird 122 John
Dog 133 Ken
Cat 144 John
Bird 177 Ken
Dog 222 Reg

I would like the list of the same data created by selecting the highest possible numbers while only selecting a Type once and selecting any particular name only 5 times. The list would stop once it reaches 50 lines of data.

So using the example above (with a max of 3 lines of data the be produced) result would be:
Dog 222 Reg
Bird 177 Ken
Cat 144 John

Can you please tell me if this is possible and recommend how to go about doing this. Or someone that could help me write this code.
Thanks
Ken

Bob Phillips · Nov 18, 2017

Code:

Public Sub KeepHighest()
Dim lastrow As Long
Dim i As Long
    
    Application.ScreenUpdating = False
    With ActiveSheet
    
        .Columns("A:C").Sort key1:=.Range("A1"), order1:=xlAscending, _
                             key2:=.Range("B1"), order2:=xlDescending, _
                             Header:=xlYes
        
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = lastrow To 3 Step -1
        
            If .Cells(i, "A").Value = .Cells(i - 1, "A").Value Then
            
                .Rows(i).Delete
            End If
        Next i
    End With
    
    Application.ScreenUpdating = True
 End Sub

Shoeboxken · Nov 19, 2017

Bob Phillips said:

Code:

Public Sub KeepHighest()
Dim lastrow As Long
Dim i As Long
    
    Application.ScreenUpdating = False
    With ActiveSheet
    
        .Columns("A:C").Sort key1:=.Range("A1"), order1:=xlAscending, _
                             key2:=.Range("B1"), order2:=xlDescending, _
                             Header:=xlYes
        
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = lastrow To 3 Step -1
        
            If .Cells(i, "A").Value = .Cells(i - 1, "A").Value Then
            
                .Rows(i).Delete
            End If
        Next i
    End With
    
    Application.ScreenUpdating = True
 End Sub

Hi Bob,
Thank you for your response. I have tried the Macro you have written and have a couple things don't work as required. Could you assist in correcting this if possible.

I noticed the list produced doesn't limit the choices to just 5 lines of data for a particular name. So it would list 7 different line entries for John and not limit his lines of data to just 5.

Secondly, the list continues until it list the highest values available for each different "type". This isn't what I was intending and I apologize if there was any confusion. I need a list created showing the highest values available without repeating a "TYPE" and only using a name 5 times total. Final row total should only be 50.

Is this possible?

When I tried your code it produced a list of all unique TYPE with its highest number and showed a list of 60.

Shoeboxken · Nov 19, 2017

Hi Bob,
Thank you for your response. I have tried the Macro you have written and have a couple things don't work as required. Could you assist in correcting this if possible.

I noticed the list produced doesn't limit the choices to just 5 lines of data for a particular name. So it would list 7 different line entries for John and not limit his lines of data to just 5.

Secondly, the list continues until it list the highest values available for each different "type". This isn't what I was intending and I apologize if there was any confusion. I need a list created showing the highest values available without repeating a "TYPE" and only using a name 5 times total. Final row total should only be 50.

Is this possible?

When I tried your code it produced a list of all unique TYPE with its highest number and showed a list of 60.

Shoeboxken · Nov 19, 2017

Hi Bob,

This macro produces a list of highest number available for each TYPE once.

What I was looking for was a list produced giving the highest number available, while only using a TYPE once and a name no more than 5 times. Key being always the highest number available. The data set that will be used will be more than 500 items. I want the list produced to include only the highest 50 numbers, while only using TYPE once for each line and the name only a max of 5.

Can you help with this?

Kind Regards,
Ken

Kenneth Hobson · Nov 19, 2017

Rule 2 could conflict with rule 3.

e.g. John has the highest number for 6 Types. The question becomes, which of the 5 would be selected? Then, because of rule 3, rule 2 for one type each is not satisfied. I guess one could check for the off chance that maybe another person had the 2nd highest and show that type number and person.

Shoeboxken · Nov 19, 2017

Hi Kenneth,

I have an idea of how I would want this to work however I just don't have the experience in writing VBA code. The idea I have is:
1. The macro would take from the data set the highest number value from column b and list the details of the row containing this value on a separate worksheet. (on this worksheet I would have set up a chart to count the number of times the name and type appear)
2. The macro would now check the count of "name" and if it equals 5 then delete from the data set all rows that contain that name.
3. Next stem would be to check the count of "type" and if it equals 1 then delete from the data set all rows that contain that type.
4. Macro would then check the number of lines of data produced on the separate worksheet and if it 49 or less it would loop the macro.

At this point once the lines produced is at 50 the macro would end production of the list from the data set.

Can you tell me if this thinking is correct and possible?

Regards
Ken

Bob Phillips · Nov 20, 2017

Provide a more realistic data set, and show us the expected results.

Kenneth Hobson · Nov 20, 2017

It is best to state goals and then rules rather than a method to solution. Most that help have their own preferred solution methods. Some of your ideas might be used but maybe not. It depends on the solution path chosen.

As Bob showed you, sorting by the number and then type is what most would probably do as a first step.

If I did it, I would add a new workbook, do the sort, and then iterate the range and fill a 50x3 array. Then it is a simple matter to write the array where you want. The question I would ask is where should the matrix result be placed? Of course I still think you might wind up missing a Type given the scenario that I explained. Others might choose a filter solution and others might just work with ranges as Bob did or as you fleshed out.

As Bob said, a more robust dataset example can often help us help you better. The closer to real world, the better. Obviously, obfuscate sensitive data. Sometimes in the real world, scenarios planned for could never happen. What good coders do is to plan for everything that might go wrong. No one can always predict every scenario but one should try when possible.

I will make an example and ignore my feared scenario for now. I may throw up a MsgBox to show if that case happened. With real data, that case may never happen. Another scenario is if there are less than 50 unique "types". Here again is where knowing the dataset helps solve the problem.

Kenneth Hobson · Nov 20, 2017

For the small dataset, this works. I would need a larger data set to test more. If less than 50 sets are found, one should add a trim for the array. I am not sure how well the Filter() step works. Another If() may be needed for more than 5 Names as the same.

Put this in a Module. Run with data in ActiveSheet. Sheet2 where the result is placed should be blank in columns A:C.

Code:

Sub Main()  
  Dim a, b, r As Range, c As Range, i As Long, j As Long
  Dim ws As Worksheet, t1$, t2$, n1$, n2$, f
  
  ReDim a(1 To 50, 1 To 3)
  Set r = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(, 3)
  Set ws = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
  r.Copy ws.[A1]
  Set r = ws.UsedRange
  r.Sort key1:=r(1, 1), order1:=xlAscending, _
    key2:=r(1, 2), order2:=xlDescending, _
    Header:=xlYes
  Set r = ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp)).Resize(, 3)
  
  ReDim b(1 To r.Rows.Count)
  a(1, 1) = r(1, 1): a(1, 2) = r(1, 2): a(1, 3) = r(1, 3)
  b(1) = a(1, 1): t1 = a(1, 1): n1 = a(1, 3): j = 1
  For i = 2 To r.Rows.Count
    t2 = r(i, 1): n2 = r(i, 3)
    If t1 = t2 Then GoTo NextI
    t1 = t2
    If n2 = n1 Then
      f = Filter(b, n2)
      If Not f Is Nothing Or UBound(f) >= 4 Then GoTo NextI
      Else
        n1 = n2
        j = j + 1
        a(j, 1) = t2: a(j, 2) = r(i, 2): a(j, 3) = n2
    End If
NextI:
  Next i
  
  Sheet2.[A1].Resize(UBound(a), UBound(a, 2)).Value = a
   ws.Parent.Close False
  Application.CutCopyMode = False
End Sub

Shoeboxken · Nov 20, 2017

Hi Kenneth,
I tried the above code however it reproduced a copy of the list along with run time error. I am uncertain how to attach a file to this reply to give a larger set of example data. The new workbook creation is unnecessary where the results could just be created on the same workbook on a new page. How can I attach a sample file?

P.S. I figured out how to attach the sample file. I already has the code you've written in place.

Kenneth Hobson · Nov 20, 2017

I miss Facebook MAA and MAA2.

There is a reason why I do the sort on a new workbook sheet. It is called speed. I guess if you want, I can add more code to disable some things to make it speed up using a new sheet in the same workbook to copy, paste, sort, delete, and add the 50 rows.

Here is the tweaked version but I still use the add workbook method. If ok, one could sort the original data, and then sort it back to some other order if needed. So, several ways to do this even using my array method.

Code:

Sub Main()  Dim a, b, r As Range, c As Range, i As Long, j As Long
  Dim ws As Worksheet, t1$, t2$, n1$, n2$, f, tf As Boolean
  
  ReDim a(1 To 50, 1 To 3)
  Set r = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(, 3)
  Set ws = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
  r.Copy ws.[A1]
  Set r = ws.UsedRange
  r.Sort key1:=r(1, 1), order1:=xlAscending, _
    key2:=r(1, 2), order2:=xlDescending, _
    Header:=xlYes
  Set r = ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp)).Resize(, 3)
  
  ReDim b(1 To r.Rows.Count)
  a(1, 1) = r(1, 1): a(1, 2) = r(1, 2): a(1, 3) = r(1, 3)
  b(1) = a(1, 1): t1 = a(1, 1): n1 = a(1, 3): j = 1
  For i = 2 To r.Rows.Count
    t2 = r(i, 1): n2 = r(i, 3)
    If t1 = t2 Then GoTo NextI
    t1 = t2
    If n2 = n1 Then
      f = Filter(b, n2)
      tf = IsArray(f)
      If tf And UBound(f) >= 4 Then GoTo NextI
      Else
        n1 = n2
        j = j + 1
        If j = 51 Then Exit For
        a(j, 1) = t2: a(j, 2) = r(i, 2): a(j, 3) = n2
    End If
NextI:
  Next i
  
  ws.Parent.Close False
  Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
  ws.[A2].Resize(UBound(a), UBound(a, 2)).Value = a
  Application.CutCopyMode = False
End Sub

Shoeboxken · Nov 20, 2017

The code seems to work in selecting 50 unique types and assuming its selecting the highest value associated with that type then this portion of result is great. The only thing missing now is on selecting 5 maximum NAME types. So if 5 of the same NAME were selected no other TYPE can be chosen from that name.

Shoeboxken · Nov 20, 2017

I suppose adding a msg box for instances where there is not enough TYPE or NAME available would be prudent.

Shoeboxken · Nov 20, 2017

Actually of further testing I notice it does not provide the highest possible number.

Kenneth Hobson · Nov 21, 2017

In the future, please make your topic/subject more descriptive than, Help. e.g. Sort and Filter Range with Maximum of 5 in Column C and 1 each Unique in Column A
That way, searches for Filter, Sort, and Unique will be obvious from Topic title.

You are using the newer code in a Sheet and the older code in a Module in one or both of the workbooks with the same name. I did not know which workbook was the latest. Sheet code is specific for that sheet and does not always work like Module code.

Put this code in a Module with a run with sheet to filter being active.

Code:

Sub Main3()  
  Dim a, b, r As Range, c As Range, i As Long, j As Long
  Dim ws As Worksheet, t1$, t2$, n1$, n2$, f, tf As Boolean
  Dim un As Long
  
  Set r = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(, 3)
  Set ws = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
  r.Copy ws.[A1]
  Set r = ws.UsedRange
  r.Sort key1:=r(1, 1), order1:=xlAscending, _
    key2:=r(1, 2), order2:=xlDescending, _
    Header:=xlYes
  Set r = ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))
  
  un = UBound(UniqueArrayByDict(r.Value)) + 1
  Set r = r.Resize(, 3)
  ReDim a(1 To un, 1 To 3)
  ReDim b(1 To r.Count)
  a(1, 1) = r(1, 1): a(1, 2) = r(1, 2): a(1, 3) = r(1, 3)
  b(1) = a(1, 1): t1 = a(1, 1): n1 = a(1, 3): j = 1
  For i = 2 To r.Count
    t2 = r(i, 1): n2 = r(i, 3)
    If t1 = t2 Then GoTo NextI
    t1 = t2
    If n2 = n1 Then
      f = Filter(b, n2)
      tf = IsArray(f)
      If tf And UBound(f) >= 4 Then GoTo NextI
      Else
        n1 = n2
        j = j + 1
        If j = un + 1 Then Exit For
        a(j, 1) = t2: a(j, 2) = r(i, 2): a(j, 3) = n2
    End If
NextI:
  Next i
  
  ws.Parent.Close False
  Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
  ws.[A2].Resize(UBound(a), UBound(a, 2)).Value = a
  ws.UsedRange.Columns.AutoFit
  Application.CutCopyMode = False
End Sub

I added the requested change to get unique column A entries rather than 50.

I could not find any case where the highest number was not returned. I only looked at 20 result rows. Maybe mark in Red the ones where it does not do what you want I guess.

Shoeboxken · Nov 21, 2017

I added the code but could not produce a result. I am not sure if I activated the sheet filter correctly. It was done in the module at the bottom left options (auto filter "true").

Kenneth Hobson · Nov 21, 2017

Put this code in a Module with a run with sheet to filter being active.

Put ALL of this into a Module. The function for post #16 did not paste apparently.

Code:

Sub Main3()  Dim a, b, r As Range, c As Range, i As Long, j As Long
  Dim ws As Worksheet, t1$, t2$, n1$, n2$, f, tf As Boolean
  Dim un As Long
  
  Set r = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(, 3)
  Set ws = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
  r.Copy ws.[A1]
  Set r = ws.UsedRange
  r.Sort key1:=r(1, 1), order1:=xlAscending, _
    key2:=r(1, 2), order2:=xlDescending, _
    Header:=xlYes
  Set r = ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))
  
  un = UBound(UniqueArrayByDict(r.Value)) + 1
  Set r = r.Resize(, 3)
  ReDim a(1 To un, 1 To 3)
  ReDim b(1 To r.Count)
  a(1, 1) = r(1, 1): a(1, 2) = r(1, 2): a(1, 3) = r(1, 3)
  b(1) = a(1, 1): t1 = a(1, 1): n1 = a(1, 3): j = 1
  For i = 2 To r.Count
    t2 = r(i, 1): n2 = r(i, 3)
    If t1 = t2 Then GoTo NextI
    t1 = t2
    If n2 = n1 Then
      f = Filter(b, n2)
      tf = IsArray(f)
      If tf And UBound(f) >= 4 Then GoTo NextI
      Else
        n1 = n2
        j = j + 1
        If j = un + 1 Then Exit For
        a(j, 1) = t2: a(j, 2) = r(i, 2): a(j, 3) = n2
    End If
NextI:
  Next i
  
  ws.Parent.Close False
  Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
  ws.[A2].Resize(UBound(a), UBound(a, 2)).Value = a
  ws.UsedRange.Columns.AutoFit
  Application.CutCopyMode = False
End Sub


'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d As Variant, Optional compareMethod As Integer = 0) As Variant
  Dim dic As Object 'Late Binding method - Requires no Reference
  Set dic = CreateObject("Scripting.Dictionary")  'Late or Early Binding method
  'Dim dic As Dictionary     'Early Binding method
  'Set dic = New Dictionary  'Early Binding Method
  Dim e As Variant
  dic.CompareMode = compareMethod
  'BinaryCompare=0
  'TextCompare=1
  'DatabaseCompare=2
  For Each e In Array1d
    If Not dic.Exists(e) Then dic.Add e, Nothing
  Next e
  UniqueArrayByDict = dic.Keys
End Function

Shoeboxken · Nov 21, 2017

I ran the macro and produced a list of now 58 items (all unique - "perfect") also showing their highest value (good but not intended result). I made some notes in the attached file for reference on the produced list after running the macro.
Expected results would be only top 50 values without repeating a TYPE and not repeating a NAME after it reaches 5 counts.
The actual data file that will be used will contain considerably more lines and repetitions.

Kenneth Hobson · Nov 21, 2017

I don't know what top 50 values means. 50 rows can be set but there are 60 unique types. If you stop it at 50, some unique Types at the end will not be considered.

As I first explained, since some Names have more than 5 top "values", those will get skipped in this latest version but then that type is skipped too. One must then get the 2nd, 3rd, 4th highest if you want to get close to that 60 count.

Here you can see, that rule 3 governed so 44 rows were returned.

Code:

Sub Main4()  
  Dim a, b, r As Range, c As Range, i As Long, j As Long
  Dim ws As Worksheet, t1$, t2$, n1$, n2$, f, tf As Boolean
  Dim un As Long
  
  Set r = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(, 3)
  Set ws = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
  r.Copy ws.[A1]
  Set r = ws.UsedRange
  r.Sort key1:=r(1, 1), order1:=xlAscending, _
    key2:=r(1, 2), order2:=xlDescending, _
    Header:=xlYes
  Set r = ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))
  
  un = UBound(UniqueArrayByDict(r.Value)) + 1
  Set r = r.Resize(, 3)
  ReDim a(1 To un, 1 To 3)
  ReDim b(1 To r.Count)
  a(1, 1) = r(1, 1): a(1, 2) = r(1, 2): a(1, 3) = r(1, 3)
  b(1) = a(1, 1): t1 = a(1, 1): n1 = a(1, 3): j = 1
  For i = 2 To r.Count
    t2 = r(i, 1): n2 = r(i, 3)
    If t1 = t2 Then GoTo NextI
    t1 = t2
    f = Filter(b, n2)
    tf = IsArray(f)
    If tf And UBound(f) >= 4 Then GoTo NextI
    n1 = n2
    j = j + 1
    If j = un + 1 Then Exit For
    a(j, 1) = t2: a(j, 2) = r(i, 2): a(j, 3) = n2
    b(j) = n2
NextI:
  Next i
  
  ws.Parent.Close False
  Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
  ws.[A2].Resize(UBound(a), UBound(a, 2)).Value = a
  ws.UsedRange.Columns.AutoFit
  Application.CutCopyMode = False
End Sub




'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d As Variant, Optional compareMethod As Integer = 0) As Variant
  Dim dic As Object 'Late Binding method - Requires no Reference
  Set dic = CreateObject("Scripting.Dictionary")  'Late or Early Binding method
  'Dim dic As Dictionary     'Early Binding method
  'Set dic = New Dictionary  'Early Binding Method
  Dim e As Variant
  dic.CompareMode = compareMethod
  'BinaryCompare=0
  'TextCompare=1
  'DatabaseCompare=2
  For Each e In Array1d
    If Not dic.Exists(e) Then dic.Add e, Nothing
  Next e
  UniqueArrayByDict = dic.Keys
End Function

I'll have to think on this more to make it get the lower values providing that the Name is not tops there too. Ergo, my initial concern.

VBA Programming help

New member

Super Moderator

New member

New member

New member

New member

New member

Super Moderator

New member

New member

New member

Attachments

New member

New member

New member

New member

Attachments

New member

New member

Attachments

New member

New member

Attachments

New member