Copy each rows and paste below in VBA

Question

I have taken and combined only unique Product Codes in Column A from all 12 sheets into Column A in Sheet1. In Sheet1, I want to copy each of the Product Codes and paste them below, means I must have 2 rows of the same Product Codes (image below) and I have about 226 Product Codes. How can I achieve this objective? Thanks in advance.

Here is my code:

Option Explicit

Sub Unique()
Dim rr As Range
Dim dta() As Variant
Dim topR As Long, foundrow As Long, mrow As Long
Dim x As Integer
Dim LastR As Long
Dim i As Integer
Dim ii As Integer
Dim OutPut() As Variant
Dim nmdRng As Range

Dim ws As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, ws5 As Worksheet, ws6 As Worksheet, ws7 As Worksheet, ws8 As Worksheet, ws9 As Worksheet, ws10 As Worksheet, ws11 As Worksheet, ws12 As Worksheet, ws13 As Worksheet
Set ws = ThisWorkbook.Worksheets("Jan")
Set ws2 = ThisWorkbook.Worksheets("Feb")
Set ws3 = ThisWorkbook.Worksheets("Mar")
Set ws4 = ThisWorkbook.Worksheets("Apr")
Set ws5 = ThisWorkbook.Worksheets("May")
Set ws6 = ThisWorkbook.Worksheets("Jun")
Set ws7 = ThisWorkbook.Worksheets("Jul")
Set ws8 = ThisWorkbook.Worksheets("Aug")
Set ws9 = ThisWorkbook.Worksheets("Sep")
Set ws10 = ThisWorkbook.Worksheets("Oct")
Set ws11 = ThisWorkbook.Worksheets("Nov")
Set ws12 = ThisWorkbook.Worksheets("Dec")
Set ws13 = ThisWorkbook.Worksheets("Sheet1")


With ws
    LastR = .Cells(.Rows.Count, "A").End(xlUp).Row
    ReDim dta(1 To 6, 1 To LastR)
    For Each rr In .Range("A1:B" & LastR)
        dta(rr.Column, rr.Row) = rr.Value
    Next rr
End With

With ws2
    LastR = .Cells(.Rows.Count, "A").End(xlUp).Row
    topR = UBound(dta, 2)
    ReDim Preserve dta(1 To 6, 1 To (topR + (LastR - 1)))
    For Each rr In .Range("A1:B" & LastR)
        dta(rr.Column, rr.Row + topR - 1) = rr.Value
        If rr.Column = 5 Then
            dta(6, rr.Row + topR - 1) = "Feb"
        End If
    Next rr
End With

With ws3
    LastR = .Cells(.Rows.Count, "A").End(xlUp).Row
    topR = UBound(dta, 2)
    ReDim Preserve dta(1 To 6, 1 To (topR + (LastR - 1)))
    For Each rr In .Range("A1:B" & LastR)
        dta(rr.Column, rr.Row + topR - 1) = rr.Value
        If rr.Column = 5 Then
            dta(6, rr.Row + topR - 1) = "03"
        End If
    Next rr
End With

With ws4
    LastR = .Cells(.Rows.Count, "A").End(xlUp).Row
    topR = UBound(dta, 2)
    ReDim Preserve dta(1 To 6, 1 To (topR + (LastR - 1)))
    For Each rr In .Range("A1:B" & LastR)
        dta(rr.Column, rr.Row + topR - 1) = rr.Value
        If rr.Column = 5 Then
            dta(6, rr.Row + topR - 1) = "04"
        End If
    Next rr
End With

With ws5
    LastR = .Cells(.Rows.Count, "A").End(xlUp).Row
    topR = UBound(dta, 2)
    ReDim Preserve dta(1 To 6, 1 To (topR + (LastR - 1)))
    For Each rr In .Range("A1:B" & LastR)
        dta(rr.Column, rr.Row + topR - 1) = rr.Value
        If rr.Column = 5 Then
            dta(6, rr.Row + topR - 1) = "05"
        End If
    Next rr
End With

With ws6
    LastR = .Cells(.Rows.Count, "A").End(xlUp).Row
    topR = UBound(dta, 2)
    ReDim Preserve dta(1 To 6, 1 To (topR + (LastR - 1)))
    For Each rr In .Range("A1:B" & LastR)
        dta(rr.Column, rr.Row + topR - 1) = rr.Value
        If rr.Column = 5 Then
            dta(6, rr.Row + topR - 1) = "06"
        End If
    Next rr
End With

With ws7
    LastR = .Cells(.Rows.Count, "A").End(xlUp).Row
    topR = UBound(dta, 2)
    ReDim Preserve dta(1 To 6, 1 To (topR + (LastR - 1)))
    For Each rr In .Range("A1:B" & LastR)
        dta(rr.Column, rr.Row + topR - 1) = rr.Value
        If rr.Column = 5 Then
            dta(6, rr.Row + topR - 1) = "07"
        End If
    Next rr
End With

With ws8
    LastR = .Cells(.Rows.Count, "A").End(xlUp).Row
    topR = UBound(dta, 2)
    ReDim Preserve dta(1 To 6, 1 To (topR + (LastR - 1)))
    For Each rr In .Range("A1:B" & LastR)
        dta(rr.Column, rr.Row + topR - 1) = rr.Value
        If rr.Column = 5 Then
            dta(6, rr.Row + topR - 1) = "08"
        End If
    Next rr
End With

With ws9
    LastR = .Cells(.Rows.Count, "A").End(xlUp).Row
    topR = UBound(dta, 2)
    ReDim Preserve dta(1 To 6, 1 To (topR + (LastR - 1)))
    For Each rr In .Range("A1:B" & LastR)
        dta(rr.Column, rr.Row + topR - 1) = rr.Value
        If rr.Column = 5 Then
            dta(6, rr.Row + topR - 1) = "09"
        End If
    Next rr
End With

With ws10
    LastR = .Cells(.Rows.Count, "A").End(xlUp).Row
    topR = UBound(dta, 2)
    ReDim Preserve dta(1 To 6, 1 To (topR + (LastR - 1)))
    For Each rr In .Range("A1:B" & LastR)
        dta(rr.Column, rr.Row + topR - 1) = rr.Value
        If rr.Column = 5 Then
            dta(6, rr.Row + topR - 1) = "10"
        End If
    Next rr
End With

With ws11
    LastR = .Cells(.Rows.Count, "A").End(xlUp).Row
    topR = UBound(dta, 2)
    ReDim Preserve dta(1 To 6, 1 To (topR + (LastR - 1)))
    For Each rr In .Range("A1:B" & LastR)
        dta(rr.Column, rr.Row + topR - 1) = rr.Value
        If rr.Column = 5 Then
            dta(6, rr.Row + topR - 1) = "11"
        End If
    Next rr
End With


With ws12
    LastR = .Cells(.Rows.Count, "A").End(xlUp).Row
    topR = UBound(dta, 2)
    ReDim Preserve dta(1 To 6, 1 To (topR + (LastR - 1)))
    For Each rr In .Range("A1:B" & LastR)
        dta(rr.Column, rr.Row + topR - 1) = rr.Value
        If rr.Column = 5 Then
            dta(6, rr.Row + topR - 1) = "12"
        End If
    Next rr
End With




ReDim OutPut(1 To UBound(dta), 1 To 1)
For i = LBound(dta, 2) To UBound(dta, 2)

foundrow = Empty
For mrow = LBound(OutPut, 2) To UBound(OutPut, 2)
If OutPut(1, mrow) = dta(1, i) And OutPut(2, mrow) = dta(2, i) And i <> mrow Then
     foundrow = mrow
     Exit For
End If
Next mrow

Dim hold As Variant

If foundrow <> Empty Then
'it exists here and one other place so let's just merge them now
'merge it
    For x = LBound(OutPut) To UBound(OutPut) 'for each column
        If x = 1 Or x = 2 Then
            OutPut(x, foundrow) = dta(x, i)
        ElseIf x = 3 Or x = 4 Or x = 5 Or x = 6 Then
             If dta(x, i) <> OutPut(x, foundrow) Then
                OutPut(x, foundrow) = dta(x, i) & "," & OutPut(x, foundrow)
            End If
        End If
    Next x
Else
    ReDim Preserve OutPut(1 To UBound(dta), 1 To UBound(OutPut, 2) + 1)
    For x = LBound(OutPut) To UBound(OutPut) 'for each column
        OutPut(x, UBound(OutPut, 2)) = dta(x, i)
    Next x
End If
Next i
Dim Rng2 As Range
With ws13
    For Each Rng2 In .Range("A1:F" & UBound(OutPut, 2))
        Rng2.Value = OutPut(Rng2.Column, Rng2.Row)
        If Rng2.Column = 5 Then
            Rng2.Value = Replace(OutPut(Rng2.Column, Rng2.Row), ",", "")

        End If
    Next Rng2
End With
End Sub

Answer 1

Without additional VBA:

First run your macro. Then in Sheet1 cell B2 enter:

=INDEX(A$2:A$100,ROUNDUP(ROWS($1:1)/2,0),0)

and copy down:

Then copy column B and PasteSpecialValues into column A

EDIT#1:

To do this without manual formula entry, first run your macro and then run:

Sub DoubleUp()
    Dim N As Long, i As Long, K As Long
    With Sheets("Sheet1")
        N = .Cells(Rows.Count, "A").End(xlUp).Row
        ReDim ary(1 To N)
        For i = 1 To N
            ary(i) = .Range("A" & i + 1)
        Next i

        K = 2
        For i = 1 To N
            .Cells(K, 1) = ary(i)
            .Cells(K + 1, 1) = ary(i)
            K = K + 2
        Next i
    End With
End Sub

EDIT#2:

Subs Unique() and DoubleUP() can be combined or you could create a Master() :

Sub Master()
  Call Unique()
  Call DoubleUp()
End Sub