Using loops to copy and paste - excel

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

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

Answer 2

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
'*******************************************************************************