I am trying to make an excel file for my parents so that they have it easier than writing all the info in a book X amount of times.

i have A; B; C; D; E; F; G; H; I; J; and L columns and want to automate and duplicate the data in A to G in rows below xn-1 times when

there is a number on Hx cell x amount of times,

where x can be from 1 to 50.

https://preview.redd.it/8p19v7ncjyo91.png?width=1859&format=png&auto=webp&s=5265abb1f6c77b418c409197e19ab836f62bd5ec before typing 10

https://preview.redd.it/xq9p3m69kyo91.png?width=1384&format=png&auto=webp&s=b06512811b45d8d7c33ff8072d58bc1f8603fa46

example data after inputting 10 or 5 respectively

thus will be inputting all the details in rows 17 and 27

CodePudding user response：

Please, test the next code. It iterates backwards, inserts the necessary number of rows (from "H" cell) and copy on them the values of between columns "A:G" of the row where "H" cell is not empty and numeric:

Sub CopyRowsNTimes()
   Dim sh As Worksheet, lastRH As Long, i As Long
   
   Set sh = ActiveSheet  'use here the sheet you need
   lastRH = sh.Range("H" & sh.rows.count).End(xlUp).row 'last row on column "H:H")
   
   Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
   For i = lastRH To 2 Step -1
        If IsNumeric(sh.Range("H" & i).Value) And sh.Range("H" & i).Value <> "" Then
            Application.CutCopyMode = False
            sh.rows(i   1 & ":" & i   sh.Range("H" & i).Value - 1).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
            sh.Range("A" & i   1, "G" & i   1   sh.Range("H" & i).Value - 2).Value = _
                 sh.Range("A" & i, "G" & i).Value
        End If
   Next i
   Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
   MsgBox "Ready..."
End Sub

Please, send some feedback after testing it.

I think, clearing the content of H:H column after processing will be a good idea. For the case you run the code for the second time, by mistake. I let it as it was, only to easily check the inserted rows...

CodePudding user response：

Duplicate Rows

Sheet Module e.g. Sheet1

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    DuplicateRows Target, "H2", 1, 50
End Sub

Standard Module e.g. Module1

Option Explicit

Sub DuplicateRows( _
        ByVal TargetCell As Range, _
        ByVal CriteriaColumnFirstCellAddress As String, _
        Optional ByVal MinTargetValue As Long = 1, _
        Optional ByVal MaxTargetValue As Long = 1)
    Const ProcName As String = "DuplicateRows"
    On Error GoTo ClearError
    
    ' Validate 'TargetCell'.
    
    'If TargetCell Is Nothing Then Exit Sub
    If TargetCell.Cells.CountLarge > 1 Then Exit Sub ' not a single cell
    
    ' Validate 'CriteriaColumnFirstCellAddress'.
    
    Dim ws As Worksheet: Set ws = TargetCell.Worksheet
    
    Dim fCell As Range
    On Error Resume Next
        Set fCell = ws.Range(CriteriaColumnFirstCellAddress)
    On Error GoTo ClearError
    If fCell Is Nothing Then Exit Sub ' invalid address
    If fCell.Cells.CountLarge > 1 Then Exit Sub ' not a single cell
    
    ' Build the Criteria (one-column) range ('crg').
    
    Dim rg As Range: Set rg = ws.UsedRange
    
    Dim crg As Range
    With fCell
        Set crg = Intersect(rg, .Resize(ws.Rows.Count - .Row   1))
    End With
    If crg Is Nothing Then Exit Sub ' not intersecting
    If Intersect(TargetCell, crg) Is Nothing Then Exit Sub ' not intersecting
    
    ' Validate 'MinTargetValue' and 'MaxTargetValue'.
    
    If MinTargetValue < 1 Then Exit Sub
    If MaxTargetValue < 1 Then Exit Sub
    
    Dim MinValue As Long
    Dim MaxValue As Long
    ' Handle if min and max are switched.
    If MinTargetValue < MaxTargetValue Then
        MinValue = MinTargetValue
        MaxValue = MaxTargetValue
    Else
        MinValue = MaxTargetValue
        MaxValue = MinTargetValue
    End If
    
    ' Validate the Target value.
        
    Dim TargetValue As Variant: TargetValue = TargetCell.Value
    If Not VarType(TargetValue) = vbDouble Then Exit Sub ' not a number
    If Int(TargetValue) <> TargetValue Then Exit Sub ' not a whole number
    Select Case TargetValue
        Case MinValue To MaxValue
        Case Else: Exit Sub ' exceeds the range of numbers
    End Select
    
    Dim rrg As Range: Set rrg = Intersect(rg, TargetCell.EntireRow)
    Dim LastRow As Long: LastRow = crg.Cells(crg.Cells.Count).Row
    Dim MaxInsertRows As Long: MaxInsertRows = ws.Rows.Count - LastRow
    If TargetValue > MaxInsertRows Then Exit Sub ' doesn't fit in the worksheet
    
    ' (Insert) Copy the data.
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    With rrg
        If .Row < LastRow Then
            .Offset(1).Resize(TargetValue).Insert _
                Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
        End If
        TargetCell.ClearContents
        .Copy Destination:=.Resize(TargetValue   1)
    End With
    
ProcExit:
    On Error Resume Next
        With Application
            If Not .EnableEvents Then .EnableEvents = True
            If Not .ScreenUpdating Then .ScreenUpdating = True
        End With
    On Error GoTo 0
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub