Copy and Paste via message box

Got 6 columns. Column A is names. The names are repeated like maybe 10 "Johns" in a row. Then maybe 7 "Sam's" in a row and so forth.The number of times a particular name is repeated varies. Need a macro to read the name,bring up a message box and ask which row of "John" I want to copy and paste to sheet 2. Then go to the "Sam's",and complete the entire column.There are about 100 names.

Hi

Try

Sub bbb()
  Dim nodupes As New Collection
  Dim OutSH As Worksheet
  
  Set OutSH = Sheets("sheet2")
  OutSH.Range("A:B").ClearContents
  On Error Resume Next
  For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    nodupes.Add Item:=Cells(i, 1).Value, key:=Cells(i, 1).Value
  Next i
  On Error GoTo 0
  
  For i = 1 To nodupes.Count
    getone = Application.InputBox("Pick a row of " & Application.CountIf(Range("A:A"), nodupes(i)) & " for " & nodupes(i), Type:=1)
    datarow = WorksheetFunction.Match(nodupes(i), Range("A:A"), 0) + getone - 1
    OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 6).Value = Cells(datarow, 1).Resize(1, 6).Value
  Next i
End Sub

This assumes that the source data starts in row 1 and sheet2 exists. There is no error checking to make sure the row specified is valid for that name.


rylo

Works great.Thank you very much.