I'm trying to set up an excel macro VBA that does the following:

Copies the value from B16 and paste it as value to the first blank row below B26. (So if B26, B27 are not blank, would paste the value to B28).

At the same time it also copies the value from A16 and pastes in the same row but in the A column, and same with C16 copying value and paste together with other values in column C.

So if B26, B27, and B28 are full. The VBA would copy values from A16, B16, and C16 and paste them to the first available row of corresponding columns (in the example, it would be A29, B29 and C29.

CodePudding user response：

Copy Values to First Empty Cell's Row

• Starting from cell B26 (inclusive) towards the bottom, it will try to find an empty cell. If found, it will copy the values from the range A16:C16 to the found cell's row of the same columns.

Option Explicit

Sub CopyToFirstEmptyCell()
    
    Const sAddress As String = "A16:C16"
    Const dAddress As String = "B26"
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    ' Reference the source range.
    Dim srg As Range: Set srg = ws.Range(sAddress)
    
    ' Reference the first empty cell below the given cell (inclusive).
    Dim dfCell As Range
    With ws.Range(dAddress) ' from the first cell...  ("B26:B1048576")
        With .Resize(ws.Rows.Count - .Row   1) ' ...  to the bottom-most cell
            Set dfCell = .Find("", .Cells(.Cells.Count), xlFormulas, xlWhole)
            If dfCell Is Nothing Then ' no cells are empty; highly unlikely
                MsgBox "No empty cells.", vbCritical
                Exit Sub
            End If
        End With
    End With
    
    ' Reference the destination range.
    Dim drg As Range: Set drg = srg.EntireColumn.Rows(dfCell.Row)
    ' srg                                "A16:C16"
    ' srg.EntireColumn                   "A:C"
    ' srg.EntireColumn.Rows(dfCell.Row)  "AdfCell.Row:CdfCell.Row"
    
    ' Copy values by assignment.
    drg.Value = srg.Value

End Sub

CodePudding user response：

Here's my approach.

The Function starts with jumping up from the very last row of your target column. It's the same function like you are using with the shortcut (CTRL ArrowUP).

On its way up, the courser stops at the first cell containing a value inside. If there is no cell with a value inside existing, it would stop at row 1 of the column.

If it was stopping on a cell lower then row 26, you know that row 26 has to be empty. Therefore, you can copy your value directly into row 26 of your column, because this is the first cell in your "collecting area".

Otherwise if it stops on a cell higher then 26, you know you have to be at the last value of your "collecting area". Next thing you have to do now is to go one row below your stopcell by using the .offset(nRows,nColumns) function, since this is the first empty cell below your "collecting area".

Option Explicit


    Public Sub main()
        Call doCopyTask(ActiveSheet.Range("A16"))
        Call doCopyTask(ActiveSheet.Range("B16"))
        Call doCopyTask(ActiveSheet.Range("C16"))
        Call doCopyTask(ActiveSheet.Range("D16"))
    End Sub
    
    
    Public Sub doCopyTask(rngSource As Range)
        ' first try getting target cell
        Dim rngTargetCell As Range
        Set rngTargetCell = ActiveSheet.Columns(rngSource.Column).Rows(ActiveSheet.Rows.Count).End(xlUp)
        ' capping targetcell to row 26, otherwise take the cell below filled cell
        If rngTargetCell.Row < 26 Then
            ActiveSheet.Columns(rngSource.Column).Rows(26).Value = rngSource.Value
        Else
            rngTargetCell.Offset(1, 0) = rngSource.Value
        End If
    End Sub