VBA 代码自动填充右侧的公式，如果满足某些条件则停止

Question

I'm currently using this code to automatically copy and paste a formula across a row to the last used column:

Sub Autofill_To_The_Right()
Dim lngLastColumn As Long
lngLastColumn = Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

Dim cell As Range
For Each cell In Selection.Columns(1).Cells
    Range(cell, Cells(cell.Row, lngLastColumn)).FillRight
Next

End Sub

While it works well, instead of it auto-filling to the last used column, I would like it to stop as soon as it encounters a completely blank column

I sometimes have tables separated by a blank column (let's say Table 1 is on the left and Table 2 on the right) and I don't want it to overwrite data in table 2 when I try and use the macro in table 1 if that makes sense

Any help would be much appreciated

Thanks,

Thomas

Answer 1

will try to adjust the last column find to support this, which just needs to handle an error if the adjacent cell is empty:

Dim r As Long, lr As Long, lc As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To lr
    If Not IsEmpty(Cells(r, 2).Value) Then
        lc = Cells(r, 1).End(xlToRight).Column
        Cells(r, 1).Copy Range(Cells(r, 2), Cells(r, lc))
    End If
Next r

---

Edit:

Annotating code to give some more help. Note that you could also .fillright using this method, where last column is found per row.

Sub fsda()
    Dim r As Long, lr As Long, lc As Long 'iterating row, last row, last column
    lr = Cells(Rows.Count, 1).End(xlUp).Row 'dynamically find last row of column 1, removing need for ".select/.activate" efforts
    For r = 2 To lr  'assumes start in row 2 as header is in row 1
        If Not IsEmpty(Cells(r, 2).Value) Then  'check for column 2 to make sure it isn't blank... this is needed for 2 reasons: 1) to ensure you don't see 'last column' as the first column of next table to the right and 2) to ensure you don't get an infinite output for lc (no error, just goes on forever)
            lc = Cells(r, 1).End(xlToRight).Column  'find last column in specific row
            Cells(r, 1).Copy Range(Cells(r, 2), Cells(r, lc))  'copies, then pastes code into specified range
        End If
    Next r
End Sub

---

Edit2:

Using .fill right:

Dim r As Long, lr As Long, lc As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To lr
    If Not IsEmpty(Cells(r, 2).Value) Then
        lc = Cells(r, 1).End(xlToRight).Column
        Range(Cells(r, 1), Cells(r, lc)).FillRight
    End If
Next r

Answer 2

Have you tried Ctrl + R? I know it's not exactly what you're looking for but it seems like it's probably the easiest solution

Answer 3

It seems to me that you simply need a different way to find the last column.

This formula will give you the closest column where there is still data, meaning that the one just after is either blank or merged with the current one.

dim row as long: row = 1 'the row number where you want to do the test
dim colOrigin as long: colOrigin = 1 'the starting column from where you want to check
with ThisWorkbook.ActiveSheet
    lColumn = .Cells(row, Application.Min(.Cells(row, colOrigin).End(xlToRight).Column + 1, Columns.Count)).End(xlToLeft).Column
end with

You can adapt it if you need it to start from a different position.

Answer 4

You could just use the following instead of lngLastColumn (as you start from first column in your code):

Dim lngLastNonBlankColumn As Long
lngLastNonBlankColumn = Range("A1").End(xlToRight).Column

Dim cell As Range
For Each cell In Selection.Columns(1).Cells
   Range(cell, Cells(cell.Row, lngLastNonBlankColumn)).FillRight
Next

Only the first table will be affected.