Question

我已经将A列中唯一的产品代码从所有12张纸中合并到了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：

可以合并子唯一（）和 DoubleUP（），也可以创建 Master（）：

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

复制每行并在VBA下面粘贴

1 个答案: