I need some help looping. I have not used VBA for sometime and starting to learn again. I remember this community helped me a lot in the past so any help is appreciated.

The Challenge

I want to copy cell H12 into the next empty column starting with i12 then J12 and so forth. So I want to continue the loop until the the number of pasted arrays equal the number in cell D12. So if Cell D12 = 20 I want to continue this loop copying H12 until I get to AB12.

Then once this is complete I want to move to the next row H13 and do the same thing. In this case D13 = 15 so we do the same as above copying H13 until we get to R13.

Any help is really appreciated. I have tried some loops for other things which have not worked out.

CodePudding user response：

Under the assumption, that your selected cell is H12 and the cells right of it are empty and D12 is filled with a positive numeric value, the following code should work:

Sub CopyToRange()

Dim ThisCol As Integer, ThisRow As Long, CurS As Worksheet, CurRg As Range, InfCol As Integer

Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 4 'column 'D'
Set CurRg = Range(CurS.Cells(ThisRow, ThisCol   1), CurS.Cells(ThisRow, ThisCol   CurS.Cells(ThisRow, InfCol).Value))
ActiveCell.Copy
CurRg.PasteSpecial (xlPasteAll)

End Sub

If you select the next row with the same preconditions it will work as well

CodePudding user response：

Duplicate Cell Values

Usage (OP)

• Copy all of the code into a standard module, e.g. Module1.
• Adjust the values in the constants section.

How to Test (Anyone)

• Add a new workbook (or just open Excel). In VBE add a new standard module and copy the code into it. In Excel, in worksheet Sheet1, in column D starting from cell D12, add some positive integers (whole numbers), and in the respective cells in column H add the values to be duplicated. Run the DuplicateCellValues procedure.

The Code

Option Explicit

Sub DuplicateCellValues()
    ' Needs the 'RefColumn' function.
    Const ProcTitle As String = "Duplicate Cell Values"
    
    Const wsName As String = "Sheet1"
    Const sFirst As String = "D12" ' Column 'D': number of duplicates.
    Const dfCol As String = "H" ' Column 'H': value to duplicate.
    
    ' Create a reference to the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    ' Create a reference to the worksheet ('ws').
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    ' Create a reference to the Source First Cell ('sfCell').
    Dim sfCell As Range: Set sfCell = ws.Range(sFirst)
    ' Create a reference to the Source Column Range ('scrg').
    Dim scrg As Range: Set scrg = RefColumn(sfCell)
    ' Check if no data in the Source Column Range was found.
    If scrg Is Nothing Then
    ' Inform and exit.
        MsgBox "There is no data in the one-column range '" _
            & sfCell.Resize(ws.Rows.Count - sfCell.Row   1).Address(0, 0) _
            & "'.", vbCritical, ProcTitle
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Dim sCell As Range ' Current Source Cell
    Dim drrg As Range ' Destination Row Range
    Dim dfCell As Range ' Destination First Cell
    
    ' Loop through the cells ('sCell') of Source Column Range.
    For Each sCell In scrg.Cells
        ' Create a reference to the current Destination First Cell.
        Set dfCell = sCell.EntireRow.Columns(dfCol)
        ' Attempt to create a reference to the Destination Row Range.
        ' It may fail if there is no whole number in the current Source Cell,
        ' or if the number is too small, or if it is too big,... etc.
        On Error Resume Next
        Set drrg = dfCell.Offset(0, 1).Resize(1, sCell.Value)
        On Error GoTo 0
        ' If the reference was created...
        If Not drrg Is Nothing Then ' *** Destination Row Range referenced.
            ' Write the value from the current First Destination Cell
            ' to the cells of the Destination Row Range.
            drrg.Value = dfCell.Value
            ' Dereference the Destination Row Range for the 'On Error Resume Next'
            ' to work 'correctly'.
            Set drrg = Nothing
        'Else ' *** Destination Row Range NOT referenced.
        End If
    Next sCell
    
    Application.ScreenUpdating = True
    
    ' Inform.
    MsgBox "Cells duplicated.", vbInformation, ProcTitle
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the one-column range from the first cell
'               of a range ('FirstCell') to the bottom-most non-empty cell
'               of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
    ByVal FirstCell As Range) _
As Range
    If FirstCell Is Nothing Then Exit Function
    
    With FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row   1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row   1)
    End With

End Function