Using loops to copy and paste

Question

I have a large set of duplicate data, I want to be able to copy each unique value and paste it twice into a new worksheet so A1 and A2 will be the same for the first value. Then for the next unique value I want A3 and A4 to be the same and so on until the end of the column. How do I do this? I'm assuming it will be some sort of for or do loop.

So assume Column C is on a different sheet, but I want the data to be simplified like this

Answer 1

Multi Unique Values

Carefully adjust the variables in the constants section. The first 7 variables should be self-explanatory.

cBlnTargetFirstRow set to True enables the calculation of the first row on the Target Worksheet e.g. if you want to append the data to the data already in that column.

cBlnTargetNewWorksheet set to True enables the output of the result in a new worksheet, which is added to the end.

cIntBuffer is an increment of the size of the Unique Array i.e. each time the array is full, that amount is added to its size.

'*******************************************************************************
' Purpose:    In a column, copies unique values, from each cell a specific
'             number of times, to another column.
'*******************************************************************************
Sub MultiUniqueValues()

  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
  End With

  On Error GoTo UnexpectedErr

  Const cVntSource As Variant = "Sheet1"          ' Source Worksheet Name/Index
  Const cVntTarget As Variant = "Sheet1"          ' Target Worksheet Name/Index
  Const cLngSourceFR As Long = 1                  ' Source First Row
  Const cLngTargetFR As Long = 1                  ' Target First Row
  Const cVntSourceC As Variant = "C"              ' Source Column Letter/Number
  Const cVntTargetC As Variant = "A"              ' Target Column Letter/Number
  Const cIntRepeat As Integer = 2                 ' Unique Values Repeat Count

  Const cBlnTargetFirstRow As Boolean = False     ' Target First Row Calculation
  Const cBlnTargetNewWorksheet As Boolean = False ' Target Worksheet Creation
  Const intBuffer As Long = 10                    ' Unique Array Resize Buffer

  Dim vntSource As Variant      ' Source Array
  Dim vntUni As Variant         ' Unique Array
  Dim vntTarget As Variant      ' Target Array

  Dim lng1 As Long              ' Source Array Counter
  Dim lng2 As Long              ' Unique Array Counter, Repeat Counter
  Dim lng3 As Long              ' Unique Values Count(er), Target Array Counter

  ' Paste column range into one-based 2-dimensional (1B2D) Source Array.
  With ThisWorkbook.Worksheets(cVntSource)
    vntSource = .Range(.Cells(cLngSourceFR, cVntSourceC), _
        .Cells(.Rows.Count, cVntSourceC).End(xlUp))
  End With

  ' Try to write first non-empty row from 1B2D Source to 1B1D Unique Array.
  For lng1 = 1 To UBound(vntSource)
    If Not IsEmpty(vntSource(lng1, 1)) Then
      ReDim vntUni(1 To intBuffer)
      vntUni(1) = vntSource(lng1, 1)
      lng3 = 1
      Exit For
    End If
  Next
  If lng1 = UBound(vntSource) + 1 Then GoTo SourceArrayErr ' No non-empty.

  ' Write the rest of the non-empty rows from 1B2D Source to 1B1D Unique Array.
  For lng1 = lng1 + 1 To UBound(vntSource)
    For lng2 = 1 To lng3
      ' Check if current row of Source Array is empty and check it against
      ' all values in current Unique Array.
      If IsEmpty(vntSource(lng1, 1)) Or _
          vntUni(lng2) = vntSource(lng1, 1) Then Exit For ' Match found.
    Next ' Match not found i.e. "'counter' = 'end' + 1".
      If lng2 = lng3 + 1 Then
        lng3 = lng2 ' (lng3 + 1)
        ' Resize 1B1D Unique Array if full.
        If (lng3 - 1) Mod intBuffer = 0 Then
          ReDim Preserve vntUni(1 To UBound(vntUni) + intBuffer)
        End If
        vntUni(lng3) = vntSource(lng1, 1) ' Write row to Unique Array.
       Else
      End If
  Next
  Erase vntSource

  ' Resize 1B1D Unique Array i.e. truncate last empty rows.
  ReDim Preserve vntUni(1 To lng3)

  ' Copy 1B1D Unique Array to 1B2D Target Array.
  ReDim vntTarget(1 To lng3 * cIntRepeat, 1 To 1)
  lng3 = 0
  For lng1 = 1 To UBound(vntUni)
    For lng2 = 1 To cIntRepeat
      lng3 = lng3 + 1
      vntTarget(lng3, 1) = vntUni(lng1)
    Next
  Next
  Erase vntUni

  ' Note:     To shorten the following code, an Object reference could have
  '           been implemented. Didn't wanna do that.

  ' Paste 1B2D Target Array into Target Range.
  If cBlnTargetNewWorksheet Then  ' Paste into range of new worksheet.
    With ThisWorkbook.Worksheets(cVntTarget)
      .Parent.Sheets.Add After:=.Parent.Sheets(Sheets.Count)
      With .Parent.Worksheets(Sheets.Count) ' It is the ActiveSheet, now.
        If cBlnTargetFirstRow Then    ' Target first row calculation enabled.
          If .Cells(.Rows.Count, cVntTargetC).End(xlUp).Row = 1 And _
              IsEmpty(.Cells(.Cells(.Rows.Count, _
              cVntTargetC).End(xlUp).Row, cVntTargetC)) Then
            .Cells(.Cells(.Rows.Count, cVntTargetC).End(xlUp).Row, _
                cVntTargetC).Resize(UBound(vntTarget)) = vntTarget
           Else
            .Cells(.Cells(.Rows.Count, cVntTargetC).End(xlUp).Row + 1, _
                cVntTargetC).Resize(UBound(vntTarget)) = vntTarget
          End If
         Else                         ' Target first row calculation disabled.
          .Cells(cLngTargetFR, cVntTargetC).Resize(UBound(vntTarget)) _
               = vntTarget
        End If
      End With
    End With
   Else                           ' Paste into range of specified worksheet.
    With ThisWorkbook.Worksheets(cVntTarget)
      If cBlnTargetFirstRow Then      ' Target first row calculation enabled.
        If .Cells(.Rows.Count, cVntTargetC).End(xlUp).Row = 1 And _
            IsEmpty(.Cells(.Cells(.Rows.Count, cVntTargetC).End(xlUp).Row, _
            cVntTargetC)) Then
          .Cells(.Cells(.Rows.Count, cVntTargetC).End(xlUp).Row, _
              cVntTargetC).Resize(UBound(vntTarget)) = vntTarget
         Else
          .Cells(.Cells(.Rows.Count, cVntTargetC).End(xlUp).Row + 1, _
              cVntTargetC).Resize(UBound(vntTarget)) = vntTarget
        End If
       Else                           ' Target first row calculation disabled.
        .Cells(cLngTargetFR, cVntTargetC).Resize(UBound(vntTarget)) _
             = vntTarget
      End If
    End With
  End If
  Erase vntTarget

ProcedureExit:
  With Application
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
  End With

Exit Sub

SourceArrayErr:
  MsgBox "No data in Source Array."
  GoTo ProcedureExit

UnexpectedErr:
  MsgBox "An unexpected error occurred. Error: '" & Err.Number & "', " _
      & Err.Description
  GoTo ProcedureExit

End Sub
'*******************************************************************************

Answer 2

You can use a collection, then input to other sheet. Sheet 2 column C has the original data.

Sub UsingCollection()
    Dim cUnique As Collection
    Dim Rng As Range, r As Long
    Dim Cell As Range
    Dim sh As Worksheet
    Dim vNum As Variant

    Set sh = ThisWorkbook.Sheets("Sheet1")
    Set ws = Sheets("Sheet2")
    Set Rng = ws.Range("C2:C" & ws.Cells(ws.Rows.Count, "C").End(xlUp).Row)
    Set cUnique = New Collection

    On Error Resume Next
    For Each Cell In Rng.Cells
        cUnique.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0

    For Each vNum In cUnique
        r = Cells(Rows.Count, "A").End(xlUp).Row + 1
        Range(Cells(r, 1), Cells(r + 1, 1)).Value = vNum

    Next vNum

End Sub