VBA script to copy adjacent cells if duplicate found

I wasn't really able to follow your code, and I am hesitant to download workbooks, but I have made this which you can tweak:

Sub test()
Dim lastRow As Integer, i As Integer
Dim cel As Range, rng As Range, sortRng As Range
Dim curString As String, nextString As String
Dim haveHeaders As Boolean

haveHeaders = False          ' Change this to TRUE if you have headers.

lastRow = Cells(1, 1).End(xlDown).Row

If haveHeaders Then          'If you have headers, we'll start the ranges in Row 2
    Set rng = Range(Cells(2, 1), Cells(lastRow, 1))
    Set sortRng = Range(Cells(2, 1), Cells(lastRow, 2))
Else
    Set rng = Range(Cells(1, 1), Cells(lastRow, 1))
    Set sortRng = Range(Cells(1, 1), Cells(lastRow, 2))
End If
' First, let's resort your data, to get all of the "Column A" values in order, which will group all duplicates together

With ActiveSheet
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange sortRng
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    ' Now, let's move all "Column B" data for duplicates into Col. C

    ' We can check to see if the cell's value is a duplicate by simply counting how many times it appears in `rng`
    Dim isDuplicate As Integer, firstInstanceRow As Integer, lastInstanceRow As Integer

    If haveHeaders Then
        curString = Cells(2, 1).Value
    Else
        curString = Cells(1, 1).Value
    End If

    Dim dupRng As Range      'set the range for the duplicates
    Dim k   As Integer

    k = 0
    For i = 1 To lastRow
        If i > lastRow Then Exit For
        Cells(i, 1).Select
        curString = Cells(i, 1).Value
        nextString = Cells(i + 1, 1).Value
        isDuplicate = WorksheetFunction.CountIf(rng, Cells(i, 1).Value)


        If isDuplicate > 1 Then
            firstInstanceRow = i
            Do Until Cells(i, 1).Offset(k, 0).Value <> nextString
                'Cells(i, 1).Offset(k, 0).Select
                lastInstanceRow = Cells(i, 1).Offset(k, 0).Row
                k = k + 1
            Loop

            Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 2)).Copy
            Cells(firstInstanceRow, 3).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            Application.CutCopyMode = False
            Range(Rows(firstInstanceRow + 1), Rows(lastInstanceRow)).EntireRow.Delete
            k = 0
            lastRow = Cells(1, 1).End(xlDown).Row
        End If
    Next i

End With

End Sub

How this works for me: I have data in Column A and B:

enter image description here

Note: I don't have headers. I used Col. A to be the column that has the possible duplicate values. First, it sorts by Col. A, to get all the numbers (or words, if alphabetical) in order. This will have all duplicates together. THen, it looks through each cell in column A, if there's more than 1 of that cell's value, move "B" info. to "C":

enter image description here

If you can post a screenshot, or just let me know where your data is, this can easily be tweaked to include more cells, other ranges, etc.

edit: quick way to loop through a column, just FYI:

Sub test()
Dim rng As Range, cel As Range
rng = ("A1:A100")

For Each cel In rng
    cel.Select
    ' Do whatever in the cell. After this is done, it'll go to the next one
    ' I chose to Select the cell because it helps me when debugging, to make sure I selected the right cells.  You can (should) comment that out when you know it works.
Next cel

End Sub