Question

有谁知道如何扩展此代码以在其粘贴中包含2个以上的数据列。（C和D列）

Sub SpecialCopy()
'Assuming A and B columns source columns
Dim i As Long, k As Long
Dim j As Long: j = 1
Dim ArrayLength As Long: ArrayLength = _
Application.WorksheetFunction.Sum(ActiveSheet.Range("B:B"))
ReDim MyArray(1 To ArrayLength) As String
For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
k = 1
Do While k <= Range("B" & i).Value
    MyArray(j) = Range("A" & i).Value
    j = j + 1
    k = k + 1
Loop
Next i
For Each MyCell In Range("a1:a" & ArrayLength)
MyCell.Value = MyArray(MyCell.Row())
MyCell.Offset(0, 1).Value = 1
Next MyCell

End Sub

目前代码将此分开：

TREVDAN    2 
CENTRAL    3 
GAL FAB    1

进入这个：

TREVDAN    1 
TREVDAN    1 
CENTRAL    1 
CENTRAL    1
CENTRAL    1
GAL FAB    1

Answer 1

试试这个：

Sub SpecialCopy()
'Assuming A and B columns source columns
Dim i As Long, k As Long
Dim j As Long: j = 1
Dim ArrayLength As Long: ArrayLength = _
Application.WorksheetFunction.Sum(ActiveSheet.Range("B:B"))
ReDim MyArray(1 To ArrayLength) As String
ReDim ArrayC(1 To ArrayLength) As String 'new
ReDim ArrayD(1 To ArrayLength) As String 'new
For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
k = 1
Do While k <= Range("B" & i).Value
    MyArray(j) = Range("A" & i).Value
    ArrayC(j) = Range("C" & i).Value 'new
    ArrayD(j) = Range("D" & i).Value 'new
    j = j + 1
    k = k + 1
Loop
Next i
For Each MyCell In Range("a1:a" & ArrayLength)
MyCell.Value = MyArray(MyCell.Row())
MyCell.Offset(0, 1).Value = 1
Next MyCell

For Each MyCell In Range("C1:C" & ArrayLength) 'new
MyCell.Value = ArrayC(MyCell.Row())
MyCell.Offset(0, 1).Value = 1
Next MyCell

For Each MyCell In Range("D1:D" & ArrayLength) 'new
MyCell.Value = ArrayD(MyCell.Row())
MyCell.Offset(0, 1).Value = 1
Next MyCell

End Sub

Answer 2

这就是我做的事情：

Sub Splitting()

'splitting up rows

     'quantity column: AI
        'Data columns: AF,AG,AH,AJ
        firstrow = Range("AF2:AJ2")
        Dim i As Long, k As Long
        Dim j As Long: j = 1
        'Next line of code is setting array length equal to the quanity column sum
        Dim ArrayLength As Long: ArrayLength = _
        Application.WorksheetFunction.Sum(ActiveSheet.Range("AI:AI"))
        'Redimentioning all data array to have this fixed array length
        ReDim First_Array(1 To ArrayLength) As String
        ReDim Second_Array(1 To ArrayLength) As String
        ReDim Third_Array(1 To ArrayLength) As String
        ReDim Fourth_Array(1 To ArrayLength) As String
        For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
        k = 1

        Do While k <= Range("AI" & i).Value
            First_Array(j) = Range("AF" & i).Value
            Second_Array(j) = Range("AG" & i).Value
            Third_Array(j) = Range("AH" & i).Value
            Fourth_Array(j) = Range("AJ" & i).Value
            j = j + 1
            k = k + 1
        Loop
        Next i

        'Data Placement
        For Each MyCell In Range("AF2:AF" & ArrayLength)
        MyCell.Value = First_Array(MyCell.Row())
        Next MyCell

        For Each MyCell In Range("AG2:AG" & ArrayLength)
        MyCell.Value = Second_Array(MyCell.Row())
        Next MyCell

        For Each MyCell In Range("AH2:AH" & ArrayLength)
        MyCell.Value = Third_Array(MyCell.Row())
        Next MyCell

        For Each MyCell In Range("AJ2:AJ" & ArrayLength)
        MyCell.Value = Fourth_Array(MyCell.Row())
        Next MyCell

        'bring back first row
        Range("AF2:AJ2").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Cut
        Range("AF3").Select
        ActiveSheet.Paste
        Range("Af1").Select
        Range("AF2:AJ2") = firstrow

        'replace quantity column with 1
        For Each MyCell In Range("AI2:AI" & ArrayLength + 1)
        MyCell.Value = 1
        Next MyCell

         End sub

Answer 3

就个人而言，如果没有阵列，我会这么做......

Sub VBA_Special_Copy_Loop()
    Dim lngLastRow As Long, rngSource As Range, iMax As Integer
    Dim x As Integer, y As Integer, WF As Object

    Set WF = Application.WorksheetFunction
    lngLastRow = Range("AF1").Offset(Rows.Count - 1).End(xlUp).Row

    Columns("AG").Insert
    With Range("AG1").Resize(lngLastRow)
        .Formula = "=ROW()"
        .Value = .Value
        .Cells(1) = "Row"
    End With

    Set rngSource = Range("AF1").Resize(lngLastRow, 6)
    iMax = WF.Max(rngSource.Columns(5))

    For x = 2 To iMax
        If WF.CountIf(rngSource.Columns(5), x) > 0 Then
            rngSource.AutoFilter Field:=5, Criteria1:=x

            For y = 2 To x
                rngSource.Copy Range("AF1").Offset(lngLastRow)
                Range("AF1").Offset(lngLastRow).Resize(, 6).Delete Shift:=xlUp
                lngLastRow = Range("AF1").Offset(Rows.Count - 1).End(xlUp).Row
            Next y
        End If
    Next x

    rngSource.AutoFilter
    Range("AF2").Resize(lngLastRow - 1, 6).Sort Key1:=Range("AG1")
    Columns("AG").Delete
End Sub

VBA特殊复制循环

3 个答案: