复制每一行并将其粘贴到VBA中

Question

我仅将所有12张工作表中A列中唯一的产品代码合并到Sheet1的A列中。 在Sheet1中，我要复制每个产品代码并将其粘贴到下面，这意味着我必须具有2行相同的产品代码（下图），并且我有大约226个产品代码。 我怎样才能实现这个目标？ 提前致谢。

这是我的代码：

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

没有附加的VBA：

首先运行您的宏。 然后在Sheet1单元格B2中输入：

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

并抄下来：

然后将B列和PasteSpecialValues复制到A列

编辑＃1：

为此，而无需手动输入公式，请先运行宏，然后运行：

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

编辑＃2：

可以将Subs Unique（）和DoubleUP（）合并，也可以创建一个Master（） ：

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