Transfer Items on a List by Quantity

[nniedzielski]

I am currently running a Macro that takes items from a List:

And I run this code to scroll through the Master Inventory worksheet and pulls anything that is on this list onto the Fruits Tab, then removes some un-needed columns, and does some formatting.

With Worksheets("Lists")
        mtArray = .Range("C2", .Range("C" & Rows.Count).End(xlUp))
    End With
    With Sheets("Master Inventory")
        .Range("A1:S1").AutoFilter field:=1, Criteria1:=Application.Transpose(mtArray), Operator:=xlFilterValues
        .AutoFilter.Range.Copy Sheets("Fruits").Range("A1")
        .AutoFilter.Range.Offset(1).EntireRow.Delete
        .Range("A1:S1").AutoFilter
    End With
    With Sheets("Fruits").Range("D:S")
        .EntireColumn.Delete
    End With
    With Sheets("Fruits").Range("A1:C1")
        .Font.Bold = True
    End With
    With Sheets("Fruits").UsedRange.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Sheets("Fruits").UsedRange.EntireColumn.AutoFit

What I need to add to this functionality is the ability to set a Max number of Fruits:

In this i would only want the macro to grab the first 12 rows of data with Lemons in it, first 5 with Oranges and so on and so forth and move them to the fruits tab.

How can i add this in?

thank you as always for any help, Stay safe

 

[DanteAmor]

Try this.
On the "lists" sheet the "fruits" should start at C2 and the maximum values at D2 downwards.

Sub test1()
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, lr As Long
  Dim sh As Worksheet, dic As Object, r As Range
 
  Set sh = Sheets("Master Inventory")
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  lr = sh.Range("A" & Rows.Count).End(3).Row
  Set r = sh.Range("A" & lr + 1)
 
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  a = sh.Range("A1:C" & lr).Value2
  b = Sheets("Lists").Range("C2:D" & Sheets("Lists").Range("C" & Rows.Count).End(3).Row).Value2
  ReDim c(1 To UBound(a), 1 To 3)
  For i = 1 To UBound(b, 1)
    dic(b(i, 1)) = b(i, 2)
  Next
 
  For i = 1 To UBound(a, 1)
    If dic.exists(a(i, 1)) And dic(a(i, 1)) > 0 Then
      Set r = Union(r, sh.Range("A" & i))
      dic(a(i, 1)) = dic(a(i, 1)) - 1
      k = k + 1
      For j = 1 To 3
        c(k, j) = a(i, j)
      Next
    End If
  Next
 
  With Sheets("Fruits")
    .Cells.ClearContents
    .Range("A1:C1").Value = sh.Range("A1:C1").Value
    .Range("A1:C1").Font.Bold = True
    If k > 0 Then .Range("A2:C2").Resize(k).Value = c
    .UsedRange.Borders.LineStyle = xlContinuous
    .UsedRange.EntireColumn.AutoFit
  End With
 
  r.EntireRow.Delete
End Sub

 

[Peter_SSs]

Here is another approach. Like your original code this copies any cell formatting from 'Master Inventory' to 'Fruits' for any cells that do get transferred.
It also assumes (as your original code appears to) that 'Fruits' has no data already in it.
My other assumption is that column Z on 'Master Inventory' is available to use as a helper, though another column could easily be chosen.

Please text with a copy of your workbook.

Sub Top_x_Fruits()
  With Sheets("Master Inventory")
    .Range("Z2").Formula = "=COUNTIF(A$2:A2,A2)<=VLOOKUP(A2,'Lists'!C:D,2,0)"
    With .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 3)
      .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=.Range("Z1:Z2"), Unique:=False
      .Copy Destination:=Sheets("Fruits").Range("A1")
      .Offset(1).EntireRow.Delete
      .Range("Z2").ClearContents
    End With
    .ShowAllData
  End With
  With Sheets("Fruits").UsedRange
    .Columns.AutoFit
    .Borders.LineStyle = xlContinuous
  End With
End Sub

 

[nniedzielski]

the formula works perfectly, but it only puts the formula in T2, how can i get it to copy down to the lastrow?

 

[nniedzielski]

Try this.
On the "lists" sheet the "fruits" should start at C2 and the maximum values at D2 downwards.

Sub test1()
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, lr As Long
  Dim sh As Worksheet, dic As Object, r As Range

  Set sh = Sheets("Master Inventory")
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  lr = sh.Range("A" & Rows.Count).End(3).Row
  Set r = sh.Range("A" & lr + 1)

  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  a = sh.Range("A1:C" & lr).Value2
  b = Sheets("Lists").Range("C2:D" & Sheets("Lists").Range("C" & Rows.Count).End(3).Row).Value2
  ReDim c(1 To UBound(a), 1 To 3)
  For i = 1 To UBound(b, 1)
    dic(b(i, 1)) = b(i, 2)
  Next

  For i = 1 To UBound(a, 1)
    If dic.exists(a(i, 1)) And dic(a(i, 1)) > 0 Then
      Set r = Union(r, sh.Range("A" & i))
      dic(a(i, 1)) = dic(a(i, 1)) - 1
      k = k + 1
      For j = 1 To 3
        c(k, j) = a(i, j)
      Next
    End If
  Next

  With Sheets("Fruits")
    .Cells.ClearContents
    .Range("A1:C1").Value = sh.Range("A1:C1").Value
    .Range("A1:C1").Font.Bold = True
    If k > 0 Then .Range("A2:C2").Resize(k).Value = c
    .UsedRange.Borders.LineStyle = xlContinuous
    .UsedRange.EntireColumn.AutoFit
  End With

  r.EntireRow.Delete
End Sub

Dante-

For whatever reason, my work laptop will not allow me to do Run dictionary. I get the activex component can't create object error message. Do you know if this is an excel setting or possibly a computer setting my work put on the laptop?

 

[snjpverma]

You will have to Add the “Microsoft Scripting Runtime” by following the below procedure.
Go to Tools->
Go to References ->
Select “Microsoft Scripting Runtime” from the long list of all the object.
Then Click OK.

then you are good to use the dictionary.

 

[Fluff]

There is no need to add a reference to the Scripting runtime library, as the code uses late binding.

@nniedzielski
Are you using a Mac?

 

[nniedzielski]

You will have to Add the “Microsoft Scripting Runtime” by following the below procedure.
Go to Tools->
Go to References ->
Select “Microsoft Scripting Runtime” from the long list of all the object.
Then Click OK.

then you are good to use the dictionary.

i had this done already.

@Fluff , its a PC and im pretty sure you already tried to get me through this a while back.

Is there any help on this question?

the formula works perfectly, but it only puts the formula in T2, how can i get it to copy down to the lastrow?

@Peter_SSs gave me code that works, but doesnt copy down

 

[Fluff]

With Peter's code the formula does not need to copy down. It's just there to drive the advanced filter.

 

[nniedzielski]

With Peter's code the formula does not need to copy down. It's just there to drive the advanced filter.

got it, for some reason it didnt work earlier, and now it does.

thanks