VBA Fill out all cells between two cells

2
votes

I am currently trying to write some VBA code which will fill out all cells between two cells with the value of the two cells.

Here is what I have :

What I currently have

And I would like the code to fill out all cells in between like this:

What I need

So, as you can see I would like all the cells in between to be filled out with the same value as the two corner cells.

Any help is very much appreciated! Thanks in advance.

2
vbaexcel
Initially there are only 2 values per row? – dot.Py
Yes, there are always only two values per row. – D. Todor
Loop through your rows. Inside that loop, loop through your columns. If cell value is not blank, set a variable equal to cell value and write it to following cells, checking if they are empty. If not empty, exit inner loop. – CMArg
Comment update: before looping through cells in a row, check if there is anything in that row (I see you have empty rows). Look here (the first short piece of code). – CMArg
I know it's not tagged as formula, just for interest it would be possible to fill in the spaces in another sheet using a formula. – Tom Sharpe

2 Answers

5
votes

you could use SpecialCells() method of Range object:

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
2
votes

Place this in a new module and run test_DTodor:

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, j).Value
                    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