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:

User selects range of cells to copy and uses shortcut to run the VBA Sub
Input box displays, asking for comma delimited list of values to use. i.e. 1,3,5,7
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!