VBA Special Copy loop

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