Change code to work on selection of cells (rather than the cell addresses in the code)

[ellison]

Hi, we've got a really handy piece of code (thank you to Kevin who posted it), which fills cells with the contents of the next non-blank cell above.
The code is:

Sub FasterFill_V4()
    Dim ws As Worksheet, a, i As Long, s As String
    Set ws = Worksheets("Sheet1")                   '<-- *** Change to actual sheet name ***
    a = ws.Range("B2:B" & ws.Cells(Rows.Count, "A").End(xlUp).Row)
    ReDim b(1 To UBound(a, 1), 1 To 1)
    
    For i = 1 To UBound(a, 1)
        If a(i, 1) <> "" Then s = a(i, 1)
        b(i, 1) = s
    Next i
    ws.Range("B2").Resize(UBound(b, 1), 1).Value = b
End Sub

We'd like if possible to change it so that the code will work on a selection of cells. So that we can then select those cells using scrolling and the mouse.

Original version before the above code is executed:

change-code-to-work-on-selection-of-cells-question.xlsm
	A	B
1	ROW	V1
2	2	alpha
3	3
4	4
5	5
6	6	1
7	7
8	8
9	9
10	10	2
11	11
12	12
13	13
14	14	charlie
15	15
16	16
17	17	delta
18	18
19	19
20	20
21	21
22	22
23	23
24	24
25	25
Sheet1

After the Kevin's code (above) is executed:

change-code-to-work-on-selection-of-cells-question.xlsm
	A	B
1	ROW	V1
2	2	alpha
3	3	alpha
4	4	alpha
5	5	alpha
6	6	1
7	7	1
8	8	1
9	9	1
10	10	2
11	11	2
12	12	2
13	13	2
14	14	charlie
15	15	charlie
16	16	charlie
17	17	delta
18	18	delta
19	19	delta
20	20	delta
21	21	delta
22	22	delta
23	23	delta
24	24	delta
25	25	delta
Sheet1

Thanks for taking a look!

 

[Alex Blakenburg]

See if this does what you are intending. Changes are in blue:

Sub FasterFill_V5()
    Dim ws As Worksheet, a, i As Long, s As String
    Set ws = ActiveSheet
    a = Selection
    ReDim b(1 To UBound(a, 1), 1 To 1)
    
    For i = 1 To UBound(a, 1)
        If a(i, 1) <> "" Then s = a(i, 1)
        b(i, 1) = s
    Next i
    ws.Range("B2").Resize(UBound(b, 1), 1).Value = b
End Sub

 

[Joe4]

BTW, loops (which are notoriously slow) are unnecessary here.
See: VBA: How to Fill Blank Cells with Value Above - Statology

 

[Alex Blakenburg]

@Joe4 - I think a single read / write using an array is still faster than the special cells-formula approach over a large recordset.

ie on 10k records @kevin9999's original code 0.0625
the special cells-formula approach 0.2265625

equivalent formula version was this:

Sub Fill_From_Above()
    Dim startTime As Double  
    startTime = Timer
  
  With Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
    .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    .Value = .Value
  End With
 
  Debug.Print Timer - startTime, "Formula Approach"
End Sub

 

[Joe4]

@Joe4 - I think a single read / write using an array is still faster than the special cells-formula approach over a large recordset.

ie on 10k records @kevin9999's original code 0.0625
the special cells-formula approach 0.2265625

equivalent formula version was this:

Sub Fill_From_Above()
    Dim startTime As Double 
    startTime = Timer
 
  With Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
    .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    .Value = .Value
  End With
 
  Debug.Print Timer - startTime, "Formula Approach"
End Sub

Ah, I guess I needed to look a bit more closely to see that the code is actually through an array and not the individual cells.

 

[ellison]

See if this does what you are intending. Changes are in blue:

Sub FasterFill_V5()
    Dim ws As Worksheet, a, i As Long, s As String
    Set ws = ActiveSheet
    a = Selection
    ReDim b(1 To UBound(a, 1), 1 To 1)
   
    For i = 1 To UBound(a, 1)
        If a(i, 1) <> "" Then s = a(i, 1)
        b(i, 1) = s
    Next i
    ws.Range("B2").Resize(UBound(b, 1), 1).Value = b
End Sub

Works absolutely beautifully, huge thanks!

 

[ellison]

Sorry - just started using this and noticed a bit of glitch:
rather than overwriting the original info with the result, the results are being put in cell B2 and below.
Is it possible to change that to "over-writing"?

This is the code that I'm using:

Sub FasterFill_V5()
    Dim ws As Worksheet, a, i As Long, s As String
    Set ws = ActiveSheet
    a = Selection
    ReDim b(1 To UBound(a, 1), 1 To 1)
    
    For i = 1 To UBound(a, 1)
        If a(i, 1) <> "" Then s = a(i, 1)
        b(i, 1) = s
    Next i
    ws.Range("B2").Resize(UBound(b, 1), 1).Value = b
End Sub

 

[Alex Blakenburg]

Try changing the last line to
Selection.Value = b
(I have logged off for the night)