VBA Special Copy loop - vba

Question

Does anyone know how i could expand this code to include 2 more columns of data in its pasting. (columns C and 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
Currently the code separates this:
TREVDAN 2
CENTRAL 3
GAL FAB 1
Into this:
TREVDAN 1
TREVDAN 1
CENTRAL 1
CENTRAL 1
CENTRAL 1
GAL FAB 1

Answer 1

Try this:
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

This is what I landed up doing:
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

Personally I would do it without the arrays...
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