Change Cell Value As Part Of Copy/Paste Operation

[CreganTur]

It's been forever since I last posted here! Good thing I remembered where to go when I had an Excel question.

Part of a data entry task involves copying a selection of cells and pasting them in the next available rows. Most often the user performing this task just has to change the value of Column C to a new value. Since doing this manually eats up a lot of time, I wanted to create code to handle this. I've got the copy/paste operation coded, but I'm having trouble with the cell value change.

Here are the steps:

1. User selects range of cells to copy and uses shortcut to run the VBA Sub
2. Input box displays, asking for comma delimited list of values to use. i.e. 1,3,5,7
3. A copy of selected cells is pasted into worksheet for each comma delimited value. 1st group has Column C value changed to 1, 2nd to 3, 3rd to 5, 4th to 7.

What do I need to do to replace the value of column C cells with one of the array values?

Sub CopyPasteWithModelIds()


    Dim NextRow As Long
    Dim NrOfCopies As Long
    Dim ModelIds As String
    Dim ModelIdArray() As String
     
    Do
         
        On Error Resume Next
        ModelIds = Application.InputBox(prompt:="Enter Model IDs as comma delimited list.", _
        Title:="Model IDs To Populate")
        On Error GoTo 0
        
        If IsEmpty(ModelIds) Then
            Exit Sub
        End If
        
        ModelIdArray = Split(ModelIds, ",")
        
        NrOfCopies = UBound(ModelIdArray)
        
        If NrOfCopies = 0 Then
            MsgBox "No copies made.", vbInformation, "CANCELLED"
            Exit Sub
        End If
         
    Loop While NrOfCopies < 1 Or NrOfCopies > NrOfCopiesMaximum
     
    With Selection
        NextRow = .Row + .Rows.Count
        Rows(NextRow & ":" & NextRow + .Rows.Count * (NrOfCopies) - 1).Insert Shift:=xlDown
        .EntireRow.Copy Rows(NextRow & ":" & NextRow + .Rows.Count * (NrOfCopies) - 1)
        .Resize(.Rows.Count * (NrOfCopies + 1)).Sort key1:=.Cells(1, 1)
    End With


End Sub

[mdmackillop]

Not 100% sure this is right; your sort code may also need fixing

Sub CopyPasteWithModelIds()     
     
    Dim NextRow As Long
    Dim NrOfCopies As Long
    Dim ModelIds As String
    Dim ModelIdArray() As String
    Dim Rws As Long, i As Long
    
    NrOfCopiesMaximum = 5  'Added to run code
    Do
        On Error Resume Next
        ModelIds = Application.InputBox(prompt:="Enter Model IDs as comma delimited list.", _
        Title:="Model IDs To Populate")
        On Error GoTo 0
         
        If IsEmpty(ModelIds) Then
            Exit Sub
        End If
         
        ModelIdArray = Split(ModelIds, ",")
         
        NrOfCopies = UBound(ModelIdArray)
         
        If NrOfCopies = 0 Then
            MsgBox "No copies made.", vbInformation, "CANCELLED"
            Exit Sub
        End If
         
    Loop While NrOfCopies < 1 Or NrOfCopies > NrOfCopiesMaximum
     
    With Selection
        Rws = .Rows.Count  'for convenience
        NextRow = .Row + Rws
        Rows(NextRow & ":" & NextRow + Rws * (NrOfCopies) - 1).Insert Shift:=xlDown
        .EntireRow.Copy Rows(NextRow & ":" & NextRow + Rws * (NrOfCopies) - 1)
        'Added @@@@@
        For i = 0 To NrOfCopies
            Cells(Selection.Row, 3).Offset(i * Rws).Resize(Rws) = ModelIdArray(i)
        Next
        '@@@@@@@
        .Resize(.Rows.Count * (NrOfCopies + 1)).Sort key1:=.Cells(1, 1)
    End With
End Sub

[CreganTur]

Hey, md! Glad to see you're still on here.

That works perfectly, thanks!