VBA Programming help

Not sure if this will help:

If I was doing this manually, my approach would be:
1. Sort the data set by number, copy the first row of data and paste to collection sheet. Collection sheet will keep a count of NAME occurrences.
2. Delete from the data set all occurrences of the TYPE that was selected in the first row.
3. Sort the modified data set by number, copy the first row of data and paste to the collection sheet. (count added)
4. Repeat until I get 5 of the same NAME. Delete from the data set all other rows of information that contain that NAME.
Repeat until I get 50 rows in collection.

By doing this I will always have the highest NUMBER available and never repeat a TYPE or more that 5 NAME repetitions by deletion process.

P.S getting the third highest or second highest number of a given TYPE during this process is what is expected because of the other rules where a TYPE cannot be repeated and a NAME no more than 5 times. Meaning that once a NAME limit was reached some TYPE's associated with that name would no longer be permitted on the list.
​
 
Last edited:
I think this is the best I can do without significant time on it. I tried to optimize the item picks (column 1) by picking those that only had one Name first.

It found 44. I did not not add a feature to truncate any over 50. That can easily be added later.

This approach uses an AutoFilter along with the previous Filter() method only more robust.
Code: 
Sub Filter1()  
  Dim a, b As Variant, f, bi As Long, i As Long, j As Long
  Dim r As Range, c As Range, u As Range, ur As Range
  Dim fr As Range, frr As Range, ws As Worksheet, un As Long
  Dim ws2 As Worksheet, ws0 As Worksheet, calc As Integer
  
   On Error GoTo EndSub
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    calc = .Calculation
    .Calculation = xlCalculationManual
  End With
  
  Set ws0 = ThisWorkbook.Worksheets(1)
  
  'Add new worksheet and sort copied range.
  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
    
  'Get Unique Number count. Force un=50.
  Set r = ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))
  ReDim b(1 To r.Count * 3) 'Array to hold Names used.
  a = UniqueArrayByDict(r.Value)
  un = UBound(a) + 1
  un = 50 'Force maximum


  'First, get only Types with one Type to maximize Type count
  For Each e In a
    ws.UsedRange.AutoFilter 1, e
    Set fr = StripFirstRow(ws.UsedRange.SpecialCells(xlCellTypeVisible))
    If fr.Rows.Count > 0 Then GoTo NextE
    bi = bi + 1
    b(bi) = fr.Cells(, 3).Value 'add Name
    f = Filter(b, b(bi))
    If UBound(f) > 5 Then GoTo NextE  'Further Single Types with that 5*Name are skipped.
  
    Set u = fr(fr.Row)
    If ur Is Nothing Then Set ur = u
    Set ur = Union(ur, u)
    bi = bi + 1
    b(bi) = fr.Cells(1, 1) 'Add Type to skip in next For loop.
NextE:
  Next e
  
  'Now, get remaining Types
  For Each e In a
    ws.UsedRange.AutoFilter 1, e
    Set fr = StripFirstRow(ws.UsedRange.SpecialCells(xlCellTypeVisible))
    
    For i = 1 To fr.Rows.Count
      Set frr = fr.Rows(i)
      
      'Skip Type due to duplicate Type?
      bi = bi + 1
      b(bi) = frr.Cells(1, 1)
      If UBound(Filter(b, b(bi))) > 0 Then GoTo NextEE
      
      'Skip to next lowest count for this Type since Name>5.
      bi = bi + 1
      b(bi) = frr.Cells(, 3) 'add Name
      f = Filter(b, b(bi))
      If UBound(f) >= 5 Then GoTo NextI
      
      Set u = frr
      If ur Is Nothing Then Set ur = u
      Set ur = Union(ur, u)
      Exit For
NextI:
    Next i
NextEE:
  Next e
  ws.AutoFilterMode = False
  
  'Add filtered data to new worksheet.
  Set ws2 = ThisWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
  ws0.[A1:C1].Copy ws2.[A1] 'Title row
  ur.Copy ws2.[a2]  'Data rows
  ws2.UsedRange.Columns.AutoFit
  
EndSub:
  On Error Resume Next
  ws.Parent.Close False 'Close scratch workbook
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = calc
    .CutCopyMode = False
  End With
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




Function StripFirstRow(aRange As Range) As Range
  Dim i As Long, j As Long, r As Range, z As Long, idx As Long
  For i = 1 To aRange.Areas.Count
    For j = 1 To aRange.Areas(i).Rows.Count
      z = z + 1
      If z = 1 Then GoTo NextJ
      If r Is Nothing Then
        Set r = aRange.Areas(i).Rows(j)
        Else
        Set r = Union(r, aRange.Areas(i).Rows(j))
      End If
NextJ:
    Next j
  Next i
  Set StripFirstRow = r
End Function
 
Last edited:
HI Kenneth,

I thank you and appreciate the effort in getting this code to work as intended. Its great that only 5 names are being selected and stopped at 45 as there are only 9 name types. I had a look at the code descriptions and noticed you went about it by selecting unique TYPES as the search function to gather the next row of data. I believe this is what is causing the incorrect output. Is there anyway to have the selection process be done by selecting the highest number available instead? There seems to be code in place to prevent more than 5 names being taken and code to make sure that only one of each type is selected.

KInd regards
Ken​
 
I can only do what you have asked. If you keep changing what you want this can go on forever.
 
I am sorry if I am making this confusing.

Original request is to have the highest number taken without reproducing a NAME more than 5 times and without reproducing a TYPE more than once. To my understanding this has not changed.

Your solution was to take the most unique TYPE and list its details and put in place a code to not repeat that type, then moved onto the next most unique type...etc...code also in place to not go over 5 names. While this may work by providing the highest value available for different types it doesn't produce the highest number available. When you run the macro and cross reference the original data set there are numbers and types that are higher and unused types produced by the macro. In fact there is an instance of BEEYAA being selected only 4 times on the produced list as it stopped at 44. I truly don't understand the code writing itself but the descriptions you have put in place made me see what may be going wrong as indicated in my previous message.

I totally understand that this is frustrating. I apologize for the confusion.
 
I am not sure I mentioned this already but the TYPE number in the actual data set will be well over 100 so the approach of using the most unique is not necessary to assure a list of 50.
 
Apparently you are not able to formulate your aims concisely.
I suspect it is because you want to keep your real situation/goal secret for this forum.
If that is correct you'd better not use a public forum at all.
It's such a waste of time of voluntary helpers and no other visitor will benefit from the content of this thread (what is the real purpose of any public forum).
 
I am not sure as to why you are being condescending towards me. I think I am pretty clear all the way through this commentary. If there was any clarification required would it not make sense to ask for an explanation?

Kenneth,

Can you please tell me what is the confusion or how did I change my request?
 
As I told you before, the rules conflicts with reality of your data.

Here are the rules restated as clearly as I can understand.
1. No Name (column C) more than 5 times.
2. Maximum values (column B) for each Type (column A which is also called Name which is confusing).
3. One Type only (column A).
4. 50 Types maximum.

Each Type can not be shown else it would violate rule 1 using your data. This is why I iterated the Types with only one Name first. This means it was the maximum for that Type. Had I not done so, those have less of a chance since rule 2 governed. That is easily skipped if you like. It just means that Types with one Name only have less chance of being picked. It makes little difference to me. It just depends on what you want to maximize.

When a maximum for a Type had the Name which was used 5 times already (rule 1), it picked the 2nd highest, 3rd highest, or none at all if all Names for that Type already had 5 Names. This is why even though you had more than 50 types, less than 50 was returned. Following some rules violates other rules in other words.

Lets say that you just want 50 out of 1,000. The way it is set up now, it sorts by Type and then Maximum. So, the first 50 are say Types A to H due to sorting by Type and then Value.


Maybe this is where you want to go?
Try looking at the big picture goal(s). Is it to get the total 50 maximum values but keep the other rules as-much-as-possible? If so, what happens when rule 1 violates that goal for a Type? We could get the 2nd, or 3rd highest for that type but that "might" violate the goal. This big picture goal can be done but I would have to rethink the logic to make it happen efficiently. It could turn out that a Type had a 2nd highest value which was higher than another Types highest value which would meet the big picture goal.
 
Last edited:
Here is the big picture method. Due to the "rules", only 45 are returned.
Code: 
Sub BigPicture()  
  Dim ws0 As Worksheet, wb As Workbook, ws As Worksheet, ws2 As Worksheet
  Dim a, a1, b1, f1, f2, un As Long, cun As Long
  Dim calc As Integer, r As Range, c As Range
  Dim r1 As Range, r2 As Range
  
  'On Error GoTo EndSub
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    calc = .Calculation
    .Calculation = xlCalculationManual
  End With
  
  Set ws0 = ThisWorkbook.Worksheets(1)  'Raw Data sheeet
  Set ws2 = ThisWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
  ws0.[A1:C1].Copy ws2.[a1] 'Title row
  Set r = ws0.Range("A1", ws0.Cells(Rows.Count, "A").End(xlUp)).Resize(, 3)
  
  'Add new worksheet and sort copied range.
  Set wb = Workbooks.Add(xlWBATWorksheet)
  Set ws = wb.Worksheets(1)
  r.Copy ws.[a1]
  Set r = ws.UsedRange
  'Sort by Value, column B, only, descending, high to low.
  r.Sort key1:=r(1, 2), order1:=xlDescending, Header:=xlYes
    
  'Get Unique Number count. Force un=50 if needed.
  Set r = ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))
  a = UniqueArrayByDict(r.Value)
  un = UBound(a) + 1
  If un > 50 Then un = 50 'Force maximum count to return.


  'Final Column A, Type
  Set r1 = ws2.Range("A2", ws2.Cells(r.Rows.Count, "A"))
  'Final Column C, Name
  Set r2 = ws2.Range("C2", ws2.Cells(r.Rows.Count, "C"))
  
  For Each c In r
    a1 = Application.Transpose(r1)  'Fill Added Types
    a2 = Application.Transpose(r2)  'Fill Added Name
    f1 = Filter(a1, c) 'Check Type
    f2 = Filter(a2, c.Offset(, 2))  'Check Name
    If UBound(f1) >= 0 Or UBound(f2) >= 4 Then GoTo NextC
    c.Resize(, 3).Copy ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
    iun = iun + 1
NextC:
    If iun = un Then Exit For
  Next c
  
  ws2.UsedRange.Columns.AutoFit
  
EndSub:
  On Error Resume Next
  wb.Close False 'Close scratch workbook
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = calc
    .CutCopyMode = False
  End With
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
 
HI Kenneth,

Once again I would like to thank you very much for your valuable time in working on this code for me. The Big Picture Method seems to be producing exactly what I would expect. Initial test seem to be great.

Just one question. Can the results be pasted to a specific page?
 
It adds a new sheet here. The line after the comment shows how to copy it to another sheet.
Code: 
 Set ws2 = ThisWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count)) 
'to the end
 ws2.usedrange.copy worksheets(7).[A1]
ws2 could just as easily have been an added workbook's sheet like ws.
 
Last edited:
Hi Kenneth,

I tried using the code above by replacing the original line and had a run time error. I tried this instead.

Set ws2 = Thisworkbook.Worksheet (3)

Will this affect the rest of the code adversely?
 
It should be fine. It will overwrite A1:C1 but you can delete or comment that out if you like.
 
Hi Kenneth,

I have attached the test file.

The overall numbers look fantastic and cant thank you enough. I did find one number that should not have been listed and wondered if you could comment on the possible cause?

The file has three pages, Sheet 1, Sheet 6, Sheet 2. I didn't want to rename things right away as to not interfere with the code. Sheet 1 is the Raw Data, Sheet 6 is the test sheet to verify what the data looks like, Sheet 2 is the output destination from running the macro. In the Test page notes in Red are items to view.

Many thanks

P.S you will need to scroll down in Sheet 6 to see where the discrepancy occurred
Ken​
 

Attachments

  • MarvelBG3.xlsm
    39.8 KB · Views: 12
Last edited:
Filter() is probably getting partial matches. Countif() should fix you up.
Code: 
Sub BigPicture2()  
  Dim ws0 As Worksheet, wb As Workbook, ws As Worksheet, ws2 As Worksheet
  Dim a, a1, b1, f1, f2, un As Long, cun As Long
  Dim calc As Integer, r As Range, c As Range
  Dim r1 As Range, r2 As Range
  
  'On Error GoTo EndSub
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    calc = .Calculation
    .Calculation = xlCalculationManual
  End With
  
  Set ws0 = ThisWorkbook.Worksheets(1)  'Raw Data sheeet
  Set ws2 = ThisWorkbook.Worksheets(3)
  Set r = ws0.Range("A1", ws0.Cells(Rows.Count, "A").End(xlUp)).Resize(, 3)
  
  'Add new worksheet and sort copied range.
  Set wb = Workbooks.Add(xlWBATWorksheet)
  Set ws = wb.Worksheets(1)
  r.Copy ws.[a1]
  Set r = ws.UsedRange
  'Sort by Value, column B, only, descending, high to low.
  r.Sort key1:=r(1, 2), order1:=xlDescending, Header:=xlYes
    
  'Get Unique Number count. Force un=50 if needed.
  Set r = ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))
  a = UniqueArrayByDict(r.Value)
  un = UBound(a) + 1
  If un > 50 Then un = 50 'Force maximum count to return.




  'Final Column A, Type
  Set r1 = ws2.Range("A2", ws2.Cells(r.Rows.Count, "A"))
  'Final Column C, Name
  Set r2 = ws2.Range("C2", ws2.Cells(r.Rows.Count, "C"))
  
  For Each c In r
    'a1 = Application.Transpose(r1)  'Fill Added Types
    'a2 = Application.Transpose(r2)  'Fill Added Name
    f1 = WorksheetFunction.CountIf(r1, c) 'Check Type
    f2 = WorksheetFunction.CountIf(r2, c.Offset(, 2))  'Check Name
    'If UBound(f1) >= 0 Or UBound(f2) >= 4 Then GoTo NextC
    If f1 >= 1 Or f2 >= 5 Then GoTo NextC
    c.Resize(, 3).Copy ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
    iun = iun + 1
NextC:
    If iun = un Then Exit For
  Next c
  
  ws2.UsedRange.Columns.AutoFit
  
EndSub:
  On Error Resume Next
  wb.Close False 'Close scratch workbook
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = calc
    .CutCopyMode = False
  End With
End Sub
 
Cant thank you enough for your patience. This code is now exactly what I was looking for.

Cheers
Ken
 
You must log in or register to reply here.
Back
Top