VBA Excel - Filling out the spaces between two cells with the value of a third one

Question

some time ago I posted a similar question here and got a great answer. But now I would need a slightly altered code but I am not able to change it up.

In an Excel sheet I have cells which have values but all cells between those two are empty. I want Excel to fill the empty cells between them with the values of a third cell. To visualise:

That's what it looks like

Now I want the macro to fill out all the empty cells with the value of the corresponding J cell. So it would look like this:

From the previous thread I used this code:

Sub main()
Dim cell As Range

For Each cell In Intersect(Columns(1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).EntireRow)
    With cell.EntireRow.SpecialCells(xlCellTypeConstants)
        Range(.Areas(1), .Areas(2)).Value = .Areas(1).Value
    End With
Next
End Sub

Is it possible to change up the existing code? Or maybe the other code from my previous, linked question? I looked into both but I myself unfortunately wasn't able.

Any help is appreciated. Thanks in advance.

score 0 · Answer 1 · answered May 26 '17 at 14:25

Use the code from the your other question but change rowval to look at column J

    Option Explicit

Sub test_DTodor()
    Dim wS As Worksheet
    Dim LastRow As Double
    Dim LastCol As Double
    Dim i As Double
    Dim j As Double
    Dim k As Double
    Dim RowVal As String

    Set wS = ThisWorkbook.Sheets("Sheet1")
    LastRow = LastRow_1(wS)
    LastCol = LastCol_1(wS)

    For i = 1 To LastRow
        For j = 1 To LastCol
            With wS
                If .Cells(i, j) <> vbNullString Then
                    '1st value of the row found
                    RowVal = .Cells(i, 10).Value --This is all I changed
                    k = 1
                    'Fill until next value of that row
                    Do While j + k <= LastCol And .Cells(i, j + k) = vbNullString
                        .Cells(i, j + k).Value = RowVal
                        k = k + 1
                    Loop
                    'Go to next row
                    Exit For
                Else
                End If
            End With 'wS
        Next j
    Next i
End Sub

Public Function LastCol_1(wS As Worksheet) As Double
    With wS
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            LastCol_1 = .Cells.Find(What:="*", _
                                After:=.Range("A1"), _
                                Lookat:=xlPart, _
                                LookIn:=xlFormulas, _
                                SearchOrder:=xlByColumns, _
                                SearchDirection:=xlPrevious, _
                                MatchCase:=False).Column
        Else
            LastCol_1 = 1
        End If
    End With
End Function

Public Function LastRow_1(wS As Worksheet) As Double
    With wS
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            LastRow_1 = .Cells.Find(What:="*", _
                                After:=.Range("A1"), _
                                Lookat:=xlPart, _
                                LookIn:=xlFormulas, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious, _
                                MatchCase:=False).Row
        Else
            LastRow_1 = 1
        End If
    End With
End Function

score 0 · Answer 2 · answered May 26 '17 at 14:29

Answer with modifying previous code

Sub main()
Dim cell As Range

For Each cell In Intersect(Columns(1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).EntireRow)
    With cell.EntireRow.SpecialCells(xlCellTypeConstants)
        Range(.Areas(1).Offset(, 1), .Areas(2).Offset(, -1)).Value = Cells(.Areas(1).Row, "J").Value
    End With
Next
End Sub

score 0 · Answer 3 · answered May 26 '17 at 14:30

Assuming you have three values in each row and they are not consecutive, a small change to your original code should suffice.

Sub main()

Dim cell As Range

For Each cell In Intersect(Columns(1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).EntireRow)
    With cell.EntireRow.SpecialCells(xlCellTypeConstants)
        Range(.Areas(1).Offset(, 1), .Areas(2).Offset(, -1)).Value = .Areas(3).Value
    End With
Next

End Sub

Tom · Answer 4 · 2017-05-26T14:55:08.930

0

This will do exactly what you want in three lines

Sub FillBlanks()
    Dim c
    For Each c In ActiveSheet.UsedRange.Columns("J").SpecialCells(xlCellTypeConstants)
        Range(c.Offset(0, c.End(xlToLeft).Column - c.Column), c.Offset(0, -c.Column + 1)).SpecialCells(xlCellTypeBlanks).Value2 = c.Value2
    Next c
End Sub

edited May 26 '17 at 14:55

answered May 26 '17 at 14:35

Tom

9,725
3
31
48

VBA Excel - Filling out the spaces between two cells with the value of a third one

4 Answers4