[VBA] Place x quantity of value in visible cells only

[RockandGrohl]

Hi guys, let's say x is a variable of a value that I want placed in a variable number of visible cells after filtering.

How I do dis?

For posterity, the range I want the cells placed is in column BD, I'd want the values placed vertically so BD2, BD3, BD4 but only where visible. How do I place 860 values of x in the first 860 visible cells in column BD?

Thanks!

 

[Marc L]

Hi,​

​

you can use SpecialCells for visible cells to allocate the value …​

 

[Peter_SSs]

Here is one way you could try with a copy of your data.

Sub Insert_value()
  Dim rA As Range
  Dim remaining As Long, rws As Long
  
  Const NumRequired As Long = 860
  Const x As String = "y"
  
  Application.ScreenUpdating = False
  remaining = NumRequired
  For Each rA In Range("BD2:BD" & Rows.Count).SpecialCells(xlVisible).Areas
    rws = rA.Rows.Count
    If rws > remaining Then rws = remaining
    rA.Resize(rws).Value = x
    remaining = remaining - rws
    If remaining = 0 Then Exit For
  Next rA
  Application.ScreenUpdating = True
End Sub

 

[RockandGrohl]

Hi,​

​

you can use SpecialCells for visible cells to allocate the value …​

Hi Marc,

Aware of this, but how do I put a value in only the first, say, 656 visible cells in one column?

 

[Peter_SSs]

how do I put a value in only the first, say, 656 visible cells in one column?

Did you try my suggestion (changing the original request for 860 values to 656)?

 

[RockandGrohl]

Hi Peter, sorry I've only just replied to this. I'll give it a whirl tomorrow and let you know. I was hoping there would be a non-looping solution as I'll be looking to add values to thousands and thousands of visible cells at a time, but I'll see how this one does for speed. Thanks!

 

[Peter_SSs]

I'll be looking to add values to thousands and thousands of visible cells at a time, but I'll see how this one does for speed.

This would be much faster. It still loops but only in memory to establish the range of cells to write to altogether at the end. For entering 10,000 values in about 2,200 disjoint ranges, this was about 10x as fast for me.
I have assumed that the number of visible cells in the column will be at least as great as the number of values you want to enter.

Sub Insert_value_v2()
  Dim rA As Range
  Dim remaining As Long, rws As Long, lr As Long

  Const NumRequired As Long = 10000
  Const x As String = "y"
  
  Application.ScreenUpdating = False
  remaining = NumRequired
  For Each rA In Range("BD2:BD" & Rows.Count).SpecialCells(xlVisible).Areas
    rws = rA.Rows.Count
    If rws >= remaining Then
      rws = remaining
      lr = rA.Row + rws - 1
      Exit For
    Else
      remaining = remaining - rws
    End If
  Next rA
  Range("BD2:BD" & lr).SpecialCells(xlVisible).Value = x
  Application.ScreenUpdating = True
End Sub

 

[RockandGrohl]

This would be much faster. It still loops but only in memory to establish the range of cells to write to altogether at the end. For entering 10,000 values in about 2,200 disjoint ranges, this was about 10x as fast for me.
I have assumed that the number of visible cells in the column will be at least as great as the number of values you want to enter.

Sub Insert_value_v2()
  Dim rA As Range
  Dim remaining As Long, rws As Long, lr As Long

  Const NumRequired As Long = 10000
  Const x As String = "y"
 
  Application.ScreenUpdating = False
  remaining = NumRequired
  For Each rA In Range("BD2:BD" & Rows.Count).SpecialCells(xlVisible).Areas
    rws = rA.Rows.Count
    If rws >= remaining Then
      rws = remaining
      lr = rA.Row + rws - 1
      Exit For
    Else
      remaining = remaining - rws
    End If
  Next rA
  Range("BD2:BD" & lr).SpecialCells(xlVisible).Value = x
  Application.ScreenUpdating = True
End Sub

Wow I literally have no idea how this works...


But it works really well!

Can I just expand the scope a little please -

So I have a variable number of product names I want to place (tref) against customers in a certain region (reg)

Let's say I have 14 different products, and there are 14 different regions. I want to allocate 1,000 of each product to each customer in each region. So 1000 customers with a reg of "A1" gets "ABC123"

Likewise, 1000 customers in B2, B3 etc get "XYZ987" and so on.


There could be a problem when I need to allocate 1,000 products, but when the client list is filtered to Region B4, there may only be 750 clients available. So it needs to fill as many as it can, up to a maximum of what the allocation states.


This is further compounded by the fact that some of our products are split, let's say again we want 1,000 of each product to each region. But one product is split like this:

Product	Allocation
ABC123	1000
XYZ987-A	500
XYZ987-B	500
DEF456	1000
GHI789	1000

So in this instance, and this is tricky, if I can't make the allocation up on one, I'd like to compensate with the other. So looking at -A, if there are only 400 eligible clients, I'd like to then allocate 600 if possible on -B, or vice versa.


To do this I'm thinking of summing the total allocation for XYZ987, which is 1,000, then setting the first initial limit as 500, if one or the other fails, then the one that didn't fail can reach the upper limit of 1,000.

This is all bloody complicated for me, which I admit is why I wanted to have a kind of one-line pasting solution. This way, I can control the situations with IF statements. This is what I have:

Private Sub LetterButton_Click()

Dim REQ As Long, tREQ As Long, VolCount As Long, LastrowPPL As Long, LastrowDF As Long
Dim reg As String, tref As String
Dim Feeder As Boolean


Set ppl = Worksheets("Price Panel Lines")
Set df = Worksheets("DataFeed")
Set fc = Worksheets("FilterCriteria")
Set op = Worksheets("Output")

CritPanel.Hide

ppl.Activate

LastrowPPL = Cells(Rows.Count, "A").End(xlUp).Row

Range("AA3:AA" & LastrowPPL).FormulaR1C1 = "=SUMIFS(C30:C30,C1,LEFT(RC1,6))"
Range("AA3:AA" & LastrowPPL).Value = Range("AA3:AA" & LastrowPPL).Value

Range("AD3").Activate
Do Until Cells(ActiveCell.Row, "A").Value = ""

Feeder = False
reg = Cells(ActiveCell.Row, "AC").Value
REQ = Cells(ActiveCell.Row, "AD").Value
tREQ = Cells(ActiveCell.Row, "AA").Value
tref = Left(Cells(ActiveCell.Row, "A").Value, 6)


op.Activate
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
LastrowDF = Cells(Rows.Count, "A").End(xlUp).Row
Range("BD1").Value = "TourRef"

Range("A1:BD" & LastrowDF).AutoFilter field:=18, Criteria1:=reg
Range("A1:BD" & LastrowDF).AutoFilter field:=56, Criteria1:=""

If Not Range("A1:A" & LastrowDF).SpecialCells(xlCellTypeVisible).Count > 1 Then
' No allocations found
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
Else
' Allocations found
    If Not Range("A1:A" & LastrowDF).SpecialCells(xlCellTypeVisible).Count >= REQ Then
    ' Partial allocations found
    VolCount = Application.WorksheetFunction.Subtotal(3, Range("A2:A" & LastrowDF))
    Range("BD2:BD" & VolCount).SpecialCells(xlCellTypeVisible).Value = tref
    Else
    ' Full allocations found
    VolCount = Application.WorksheetFunction.Subtotal(3, Range("A2:A" & LastrowDF))
    
    remaining = REQ
    For Each rA In Range("BD2:BD" & LastrowDF).SpecialCells(xlCellTypeVisible).Areas
    rws = rA.Rows.Count
    If rws >= remaining Then
    rws = remaining
    lr = rA.Row + rws - 1
    Exit For
    Else
    remaining = remaining - rws
    End If
    Next rA
    Range("BD2:BD" & lr).SpecialCells(xlCellTypeVisible).Value = tref
    
    End If

End If



ActiveCell.Offset(1, 0).Activate
Loop

'Call letterexport
End Sub

Not everything is currently dimmed properly, but yeah that bottom part of the IF statement with your logic is currently what happens when reg is filtered and there are enough clients to fill the allocation up.

Cheers!

 

[RockandGrohl]

Jesus helps those who help themselves.

Right. At this point, the code has three out of four settings complete.

1) There are enough visible rows to fulfill the allocation requirement - Fills up to the requirement.

2) There are not enough visible rows to fulfill the allocation requirement - Fills as many as it can, and writes the remaining figure on a sheet next to the original requirement

3) There are no rows - removes all filters and iterates down to the next product


So the final step, step 4, is the re-loop back from the top and where there is capability to add missing allocation onto a split product, then do so. I'll work on that later.

For now, can anything here be improved, have I done anything in a catastrophically stupid way? I'm just getting to grips with areas, but I think it makes sense. That's why in the filter section for where there isn't quite enough, I'm counting the number of areas that I am looping through. When I get to the top, I stop, find the last row of that final area and then wang the products in.

Private Sub LetterButton_Click()

Dim REQ As Long, tREQ As Long, VolCount As Long, rws As Long, LastrowPPL As Long, LastrowDF As Long, AreaLR As Long
Dim reg As String, tref As String
Dim Feeder As Boolean
Dim area As Range
Dim x As Integer, z As Integer


Set ppl = Worksheets("Price Panel Lines")
Set df = Worksheets("DataFeed")
Set fc = Worksheets("FilterCriteria")
Set op = Worksheets("Output")

CritPanel.Hide

ppl.Activate

Range("AA2").Value = "Route Requirement"
Range("AB2").Value = "Remaining"
Range("AD2").Value = "Coach Requirement"
Columns(28).NumberFormat = "#0"

LastrowPPL = Cells(Rows.Count, "A").End(xlUp).Row

Range("AA3:AA" & LastrowPPL).FormulaR1C1 = "=SUMIFS(C30,C1,LEFT(RC1,6)&""*"")"
Range("AA3:AA" & LastrowPPL).Value = Range("AA3:AA" & LastrowPPL).Value

Range("AD3").Activate
Do Until Cells(ActiveCell.Row, "A").Value = ""

Feeder = False
reg = Cells(ActiveCell.Row, "AC").Value
REQ = Cells(ActiveCell.Row, "AD").Value
tREQ = Cells(ActiveCell.Row, "AA").Value
tref = Left(Cells(ActiveCell.Row, "A").Value, 6)


op.Activate
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
LastrowDF = Cells(Rows.Count, "A").End(xlUp).Row
Range("BD1").Value = "TourRef"

Range("A1:BD" & LastrowDF).AutoFilter field:=18, Criteria1:=reg
Range("A1:BD" & LastrowDF).AutoFilter field:=56, Criteria1:=""

If Not Range("A1:A" & LastrowDF).SpecialCells(xlCellTypeVisible).Count > 1 Then
' No allocations found
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
Else
' Allocations found
    If Not Range("A1:A" & LastrowDF).SpecialCells(xlCellTypeVisible).Count >= REQ + 1 Then
    ' Partial allocations found
    VolCount = Application.WorksheetFunction.Subtotal(3, Range("A2:A" & LastrowDF))
    
    Remaining = REQ
    x = 0
    z = 0
    z = Range("BD2:BD" & LastrowDF).SpecialCells(xlCellTypeVisible).Areas.Count
    
    For Each area In Range("BD2:BD" & LastrowDF).SpecialCells(xlCellTypeVisible).Areas
        rws = area.Rows.Count
        If rws >= Remaining Then
            rws = Remaining
            AreaLR = area.Row + rws - 1
            Exit For
        Else
            Remaining = Remaining - rws
            x = x + 1
            If x = z Then Exit For
        End If
        Next area
        
        AreaLR = area.Row + rws - 1
        Range("BD2:BD" & AreaLR).SpecialCells(xlCellTypeVisible).Value = tref
        ppl.Activate
        Cells(ActiveCell.Row, "AB").Value = Remaining
        
    Else
        ' Full allocations found
        VolCount = Application.WorksheetFunction.Subtotal(3, Range("A2:A" & LastrowDF))
        
        Remaining = REQ
        For Each area In Range("BD2:BD" & LastrowDF).SpecialCells(xlCellTypeVisible).Areas
            rws = area.Rows.Count
        If rws >= Remaining Then
            rws = Remaining
            AreaLR = area.Row + rws - 1
            Exit For
        Else
            Remaining = Remaining - rws
        End If
        Next area
        Range("BD2:BD" & AreaLR).SpecialCells(xlCellTypeVisible).Value = tref
        ppl.Activate
        Cells(ActiveCell.Row, "AB").Value = Remaining
    End If

End If


ppl.Activate
ActiveCell.Offset(1, 0).Activate
Loop

'Call letterexport
End Sub

 

[RockandGrohl]

Bump - I have this problem more or less solved and have marked it as such, but is there a way I can improve the code I've written for readability / usage?

Thanks!