Sub ddf()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim x As Double
Dim y As Double
Do Until Range("a1").Value = ""
x = InStr(1, Range("a1"), ".")
y = InStr(1, Range("a1"), "?")
lr = Cells(Rows.Count, 1).End(xlUp).Row
If x > y Then
Range("a" & lr + 1).Formula = Left(Range("a1"), y)
Range("a1") = Replace(Range("a1"), Range("a" & lr + 1), "")
ElseIf x = 0 Then
Range("a" & lr + 1).Formula = Left(Range("a1"), y)
Range("a1") = Replace(Range("a1"), Range("a" & lr + 1), "")
ElseIf y = 0 Then
Range("a" & lr + 1).Formula = Left(Range("a1"), x - 1)
Range("a1") = Replace(Range("a1"), Left(Range("a1"), x), "")
Else
Range("a" & lr + 1).Formula = Left(Range("a1"), x - 1)
Range("a1") = Replace(Range("a1"), Left(Range("a1"), x), "")
End If
Loop
Exit Sub
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
In above code i want to loop the steps till range("a1") become blank. Please tell me where need corrections in above code.
Place
x = InStr(1, Sheets("sheet1").Range("a1"), ".")
y = InStr(1, Sheets("sheet1").Range("a1"), "?")
Also right before
Loop
And place both just after the last
End If
Related
I´m pretty new to VBA and since it´s making my job so much easier I try to write some codes from time to time and everything works fine except for this one, I already tried with the Screen Updating and the Status Bar method but it´s still very slow. Any ideas on how it coul be improved? Thnak you
Sub DW()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Dim i As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
i = 1
Do Until i > LastRow
If Range("B" & i) = Range(B & i + 1) Then
Range("L" & i) = Range("L" & i) + Range("L" & i + 1)
Range("M" & i) = Range("M" & i) + Range("M" & i + 1)
Range("N" & i) = Range("N" & i) + Range("N" & i + 1)
Range("O" & i) = Range("O" & i) + Range("O" & i + 1)
Range("P" & i) = Range("P" & i) + Range("P" & i + 1)
Range("Q" & i) = Range("Q" & i) + Range("Q" & i + 1)
Range("A" & i + 1).EntireRow.Delete
LastRow = LastRow - 1
Else
i = i + 1
End If
Loop
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub
This does what your code does; i tested with 1k rows of data and it was faster then your code. (Updated with ja72's input)
Dim i As Long
Dim LastRow As Long
If Range("B1") = Range("B2") Then
Rows(1).Copy
Rows(1).Insert Shift:=xlDown
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Cells(1, 12).Formula = "=SUM(L2:L" & LastRow & ")"
Cells(1, 12).Resize(, 5).FillRight
End If
Range("L1").Resize(1,10).Value = Range("L1").Resize(1,10).Value
Rows(2 & ":" & Rows.Count).Delete
The code below first addresses the issue of string math for the range picking. Instead of .Range("A" & i) it best to use .Offset() or .Cells() instead. Additionally it makes it explicit that we are dealing with values and not ranges when the math takes place. It is recommended to always type .Value where it is implied.
Sub DW()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Dim i As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim r As Range, g As Range
' Set the start of the optimization loop
Set r = Range("B1")
' While still inside the data
Do While r.Row <= LastRow
' Check this value with value of next row
If r.Value = r.Offset(1, 0).Value Then
Set g = r.Offset(0, 10) ' Pick column "L" of same row as r
Go from "L" to "Q"
For i = 1 To 6
'Add values one by one with row below
g.Offset(0, i - 1).Value = _
g.Offset(0, i - 1).Value + g.Offset(1, i - 1).Value
Next i
r.Offset(1, 0).EntireRow.Delete
LastRow = LastRow - 1
End If
' Move to next row
Set r = r.Offset(1, 0)
Loop
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub
Depending on the total amount of data, it will be way faster to load all the data into memory and process it with VBA arrays only to be returned back in the end to the worksheet.
The following code should be orders of magnitude faster.
Sub DW2()
Dim i As Long, j As Long, i_out As Long, i_next As Long
Dim LastRow As Long, ValCol As Long, LastCol As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
ValCol = Cells(, "L").Column
LastCol = Cells(, "Q").Column
Dim r_data As Range
' Reference all the data (filled rows, and 17 columns "A:Q")
Set r_data = Range("A1").Resize(LastRow, LastCol)
' x is input data, y as output data
Dim x() As Variant, y() As Variant
' Copy all the table cells into memory
x = r_data.Value
' Create an empty array at least the same size
ReDim y(1 To LastRow, 1 To LastCol)
' i_out is index for output
i_out = 1
' i is index for input
For i = 1 To LastRow
' Debug.Print "Row"; i, "into Row:"; i_out
'Copy all values first from current row
For j = 1 To LastCol
y(i_out, j) = x(i, j)
Next j
' Index i_next peeks at the next row
i_next = i + 1
If i_next >= LastRow Then
' Advance i_out
i_out = i_out + 1
Exit For
End If
' Check with value match on 2nd column "B"
Do While x(i, 2) = x(i_next, 2)
'Add up values in columns 11 through 17
For j = ValCol To LastCol
y(i_out, j) = y(i_out, j) + x(i_next, j)
Next j
' Peek at subsequent rows also
i_next = i_next + 1
If i_next >= LastRow Then
' Advance i_out
i_out = i_out + 1
Exit For
End If
Loop
' Advance i if rows were skipped
i = i_next - 1
' Advance i_out
i_out = i_out + 1
Next i
' Clear all table cells
r_data.ClearContents
' Overwrite with the optimized values
r_data.Resize(i_out - 1, LastCol).Value = y
End Sub
Edit: Now tested for robustness when matching rows exist in the end of the data
I have three columns, one of them having all the staff list IDs, the second is having Front-Line staff IDs, The third is having the Back-office staff IDs, sometimes we change the task to some of them, to work in the different field, So His Staff ID has to disappear from Front-Line col and appear in Back-Office col instead. and Vice-Versa, and this will be done by selecting some of Column A staff, then it will loop through Col B and remove selection value(If found), then add these selected cells to Col B.
The same when we normalize, we select some staff from Col A, It should remove the staff IDs from Col B and add it to col C
All Staff | Front-line | Back-Office
15348 | 15348 | 15344
15347 | 15347 | 15345
15345 |
15344 |
What I've achieved so far.
Excuse me if my codes looks a little bit complex, that's the only way I know.
Dedicate Button (Dedicating 1st Col staffs to work as Back-office)
Dim found As Boolean
Dim i, j, mycount, dedlist As Integer
Dim firstempty As Long
With Sheets("StaffList")
firstempty = .Range("H" & .Rows.Count).End(xlUp).Row + 1
dedlist = .Range("L" & .Rows.Count).End(xlUp).Row
End With
mycount = firstempty - 1
found = False
Selection.Copy
With Sheets("StaffList")
firstempty = .Range("H" & .Rows.Count).End(xlUp).Row + 1
Cells(firstempty, 8).Select
Cells(firstempty, 8).PasteSpecial Paste:=xlPasteValues
End With
With Sheets("StaffList")
firstempty = .Range("H" & .Rows.Count).End(xlUp).Row + 1
dedlist = .Range("L" & .Rows.Count).End(xlUp).Row
End With
mycount = firstempty - 1
For i = 2 To mycount
For j = 2 To dedlist
With Sheets("StaffList")
If .Range("H" & i).Value = .Range("L" & j).Value Then
found = True
End If
End With
Next j
If found = False Then
dedlist = dedlist + 1
With Sheets("StaffList")
.Range("L" & dedlist).Value = .Range("H" & i).Value
End With
End If
found = False
Next i
' ActiveSheet.Range("$H$1:$H$500").RemoveDuplicates Columns:=1, Header:=xlYes
Range("A1").Select
Normalize Button (Normalizing 2nd Col staffs to get back working as Front-Line)
Dim CompareRange As Variant, x As Variant, y As Variant
Dim rng As Range
Dim found As Boolean
Dim i, j, mycount, dedlist As Integer
Dim firstempty As Long
With Sheets("StaffList")
firstempty = .Range("M" & .Rows.Count).End(xlUp).Row + 1
dedlist = .Range("H" & .Rows.Count).End(xlUp).Row
End With
mycount = firstempty - 1
found = False
Selection.Copy
With Sheets("StaffList")
firstempty = .Range("M" & .Rows.Count).End(xlUp).Row + 1
Cells(firstempty, 13).Select
Cells(firstempty, 13).PasteSpecial Paste:=xlPasteValues
End With
With Sheets("StaffList")
firstempty = .Range("M" & .Rows.Count).End(xlUp).Row + 1
dedlist = .Range("H" & .Rows.Count).End(xlUp).Row
End With
mycount = firstempty - 1
For i = 2 To mycount
For j = 2 To dedlist
With Sheets("StaffList")
If .Range("M" & i).Value = .Range("L" & j).Value Then
.Range("H" & j).Value = ""
End If
End With
Next j
Next i
Range("A1").Select
This is the VBA implementation of the suggestion in comment:
Option Explicit
Public Sub UpdateStaffTasks()
Const FRNT = "Front-line", BACK = "Back-Office"
Dim selRow As Variant, lrSelRow As Long, ws As Worksheet, i As Long, j As Long
Dim usdRng As Variant, lrUsdRng As Long, red As Long, blu As Long
If Selection.Cells.Count = 1 And Selection.Row = 1 Then Exit Sub
Set ws = Selection.Parent
selRow = GetSelRows(Selection): lrSelRow = UBound(selRow): red = RGB(256, 222, 222)
usdRng = ws.UsedRange: lrUsdRng = UBound(usdRng): blu = RGB(222, 222, 256)
For i = 0 To lrSelRow
For j = i + 2 To lrUsdRng
If j = Val(selRow(i)) Then
If Len(usdRng(j, 1)) > 0 And Len(usdRng(j, 2)) > 0 Then
usdRng(j, 2) = IIf(usdRng(j, 2) = FRNT, BACK, FRNT)
With ws.Cells(j, 1).Resize(, 2).Interior
.Color = IIf(usdRng(j, 2) = FRNT, red, blu)
End With
Exit For
End If
End If
Next
Next
Selection.Parent.UsedRange = usdRng
End Sub
Public Function GetSelRows(ByRef selectedRange As Range) As Variant
Dim s As Variant, a As Range, r As Range, result As Variant
If selectedRange.Cells.Count > 1 Then
For Each a In selectedRange.Areas
For Each r In a.Rows
If r.Row > 1 And InStr(s, r.Row) = 0 Then s = s & r.Row & " "
Next
Next
GetSelRows = Split(RTrim$(s)): Exit Function
Else
GetSelRows = Array(selectedRange.Row): Exit Function
End If
End Function
Before and After:
I have the below code that does the following:
Checks the date in Col K
If the date is a Sunday and if the "P" col has the text "Moved to SA", it will not color the values in Col M in red.
Example format: M/D/YYY TIME - 1/22/2017 21:00
What I want to add to the above logic is:
The code should also check for Saturday along with the time i.e. If the time on Saturday is more than 6PM (18:00), then it should not color the value in Col M.
I just need to add this one condition in my code.
Sub SundayDatefilter()
Dim r, lastrow, remainingDay As Long
lastrow = Range("M:P").Cells(Rows.count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For r = 2 To lastrow
remainingDay = 0
If Weekday(Range("K" & r).Value, vbSunday) = 1 Then
remainingDay = Round((24 - Format(TimeValue(Range("K" & r)), "h")) / 24, 1)
If InStr(1, Range("P" & r).Text, "*Moved to SA*", vbTextCompare) > 0 Then
If Range("M" & r) - remainingDay >= 1 Then
Range("M" & r).Cells.Font.ColorIndex = 3
Else
Range("M" & r).Cells.Font.ColorIndex = 0
End If
End If
End If
Next r
Application.ScreenUpdating = True
End Sub
Logically, there is no need to add that test :
Your first test is to check if the date is a SUNDAY
If it is not, you won't go further for that row
So if the date is a SATURDAY, you won't color anything!
I've modified a bit your code :
As you declared your variables r and lastrow were Variants!
I've added a reference to the sheet (here Sheet1) to increase robustness and performance
Here is your code :
Sub SundayDatefilter()
Application.ScreenUpdating = False
Dim wS As Worksheet, _
r As Long, _
LastRow As Long, _
RemainingDay As Long
Set wS = ThisWorkbook.Sheets("Sheet1")
With wS
LastRow = .Range("M:P").Cells(.Rows.Count, "A").End(xlUp).Row
For r = 2 To LastRow
RemainingDay = 0
If Weekday(.Range("K" & r).Value, vbSunday) = 1 Then
RemainingDay = Round((24 - Format(TimeValue(.Range("K" & r)), "h")) / 24, 1)
If InStr(1, .Range("P" & r).Text, "*Moved to SA*", vbTextCompare) > 0 Then
If .Range("M" & r) - RemainingDay >= 1 Then
.Range("M" & r).Cells.Font.ColorIndex = 3
Else
.Range("M" & r).Cells.Font.ColorIndex = 0
End If
End If
End If
If Weekday(.Range("K" & r).Value, vbSunday) = 7 and TimeValue(.Range("K" & r))>TimeValue("18:00:00") Then
RemainingDay = Round((24 - Format(TimeValue(.Range("K" & r)), "h")) / 24, 1)
If InStr(1, .Range("P" & r).Text, "*Moved to SA*", vbTextCompare) > 0 Then
If .Range("M" & r) - RemainingDay >= 1 Then
.Range("M" & r).Cells.Font.ColorIndex = 3
Else
.Range("M" & r).Cells.Font.ColorIndex = 0
End If
End If
End If
Next r
End With 'wS
Application.ScreenUpdating = True
End Sub
I have 2 workbooks called "Source1" and "Source2".
For each cell in the last column of "Source1" I check if it exists in the last column of "Source2".
If yes, then I copy 4 separate cells from that row based on some critea into a new workbook called "Target".
My macro is working but as I have thousands of cells to loop through, it takes me at least 10 min till the macro finishes. I am running it many times a day so I want to optimize my code so that it will take less time.
Here is my code
Sub Loop_Cells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
Dim Source, Source2, Target As Workbook
Dim c As Range
Dim lRow, lRow2 As Long
Dim x, y, w As Integer
Set Source = Workbooks.Open("C:\Reports\Source1.xlsx")
Source.Activate
x = ActiveSheet.UsedRange.Columns.Count
ActiveSheet.Cells(1, x + 1) = "Concate"
lRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lRow
ActiveSheet.Cells(i, x + 1).Value = ActiveSheet.Cells(i, 6).Value & ActiveSheet.Cells(i, 7).Value
Next i
ActiveSheet.Columns(x + 1).NumberFormat = "0"
Set Source2 = Workbooks.Open("C:\Reports\Source2.xlsx")
Source2.Activate
y = ActiveSheet.UsedRange.Columns.Count
ActiveSheet.Cells(1, y + 1) = "Concate"
lRow2 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lRow2
ActiveSheet.Cells(i, y + 1).Value = ActiveSheet.Cells(i, 48).Value & ActiveSheet.Cells(i, 3).Value
Next i
ActiveSheet.Columns(y + 1).NumberFormat = "0"
Set Target = Workbooks.Add
Target.Sheets(1).Name = "ExistCells"
Source.Sheets(1).Activate
w = 1
For Each c In Source1.Sheets(1).UsedRange.Columns(x + 1).Cells
For j = 2 To lRow2
If c.Value = Source2.Sheets(1).Cells(j, y + 1).Value Then
Target.Sheets(1).Cells(w, 1).Value = Source2.Sheets(1).Cells(j, 48).Value
Target.Sheets(1).Cells(w, 2).Value = Source2.Sheets(1).Cells(j, 3).Value
Target.Sheets(1).Cells(w, 3).Value = Source2.Sheets(1).Cells(j, 27).Value
Target.Sheets(1).Cells(w, 4).Value = Source2.Sheets(1).Cells(j, 41).Value
w = w + 1
End If
Next j
Next c
Workbooks("Source1.xlsx").Close SaveChanges:=False
Workbooks("Source1.xlsx").Close SaveChanges:=False
Target.Activate
ActiveWorkbook.SaveAs FileName:= "C:\Reports\Target.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I think the problem is in this part, when the cell exists I don't need to loop till the last row and I should move to the next.
For j = 2 To lRow2
If c.Value = Source2.Sheets(1).Cells(j, y + 1).Value Then ...
Any Suggestions how to adjust my code?
Collections: VBA.Collection, Scripting.Dictionary, ArrayList, Queue, Stack ... etc.
Collections are optimized for fast lookups. For this reason,they are ideal when matching values.
Consider matching two lists each with 1000 values. Assuming that on average you find a match half way through the list, that's (500 * 1000) or 500K operations. Using a Collection would reduce the number to 1000 iterations + 1000 lookups. Assuming that it takes 1 to 10 operations per lookup (just a guess) then you would reduce the number of operations that it takes to compare two 1000 element lists from 500K to 6K.
Arrays: Reading and writing to arrays is much faster then reading and writing to file (worksheet).
Once a match is found you write 4 values to the new worksheet. Let's say you find 1000 matches, that's 4000 write operations to the worksheet. If instaed you hold these values in an array and then write the array to the worksheet you'll reduce the number of write operations (to the worksheet) from 400 to 1.
Using these techniques should reduce the run time from 10+ minutes to under 20 seconds.
Sub NewLoop()
Application.ScreenUpdating = False
Application.SheetsInNewWorkbook = 1
Dim data As Variant, result As Variant
Dim lastRow As Long, x As Long, x1 As Long
Dim key As String
Dim list As Object
Set list = CreateObject("System.Collections.ArrayList")
With Workbooks.Open("C:\Reports\Source1.xlsx")
With .Worksheets(1)
data = .Range("F2:G" & .Range("A" & Rows.Count).End(xlUp).Row).Value
For x = 1 To UBound(data, 1)
'Create a Unique Identifier using a pipe to delimit the data
'This will keep the data from mixing
key = data(x, 1) & "|" & data(x, 2)
If Not list.Contains(key) Then list.Add key
Next
End With
.Close SaveChanges:=False
End With
With Workbooks.Open("C:\Reports\Source2.xlsx")
With .Worksheets(1)
lastRow = .Range("A" & Rows.Count).End(xlUp).Row
ReDim result(1 To lastRow, 1 To 4)
For x = 2 To lastRow
'Create a Unique Identifier using a pipe to delimit the data
'This will keep the data from mixing
key = .Cells(i, 48).Value & "|" & .Cells(i, 3).Value
If list.Contains(key) Then
x1 = x1 + 1
result(x1, 1) = .Cells(j, 48).Value
result(x1, 2) = .Cells(j, 3).Value
result(x1, 3) = .Cells(j, 27).Value
result(x1, 4) = .Cells(j, 41).Value
End If
Next
End With
.Close SaveChanges:=False
End With
With Workbooks.Add
With Worksheets(1)
.Name = "ExistCells"
.Range("A1:D1").Resize(x1).Value = Results
End With
End With
Application.ScreenUpdating = True
End Sub
Following on from your last point, could you not just exit the loop when the If condition is met? Something like this for example?
For j = 2 To lRow2
If c.Value = Source2.Sheets(1).Cells(j, y + 1).Value Then
Target.Sheets(1).Cells(w, 1).Value = Source2.Sheets(1).Cells(j, 48).Value
Target.Sheets(1).Cells(w, 2).Value = Source2.Sheets(1).Cells(j, 3).Value
Target.Sheets(1).Cells(w, 3).Value = Source2.Sheets(1).Cells(j, 27).Value
Target.Sheets(1).Cells(w, 4).Value = Source2.Sheets(1).Cells(j, 41).Value
w = w + 1
GoTo ExitLoop
End If
Next j
ExitLoop:
The code could be cleaned up a bit...plus you were closing "Source1.xlsx" twice...and tried to refer to Source1 as a variable even though it was never declared. Using Option Explicit at the top of the module will allow you find that type of issue easily. I put in a similar break in the inner For loop like Wilson88 as well.
By using your variables and With you should be able to speed it up some over ActiveWorkbook and ActiveSheet...
Sub Loop_Cells()
Dim Source As Workbook, Source2 As Workbook, Target As Workbook
Dim w As Integer, x As Integer, y As Integer
Dim lRow As Long, lRow2 As Long
Dim c As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
Set Source = Workbooks.Open("C:\Reports\Source1.xlsx")
With Source
x = .UsedRange.Columns.Count
.Cells(1, x + 1) = "Concate"
lRow = .Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lRow
.Cells(i, x + 1) = .Cells(i, 6). & .Cells(i, 7)
Next i
.Columns(x + 1).NumberFormat = "0"
End With
Set Source2 = Workbooks.Open("C:\Reports\Source2.xlsx")
With Source2
y = .UsedRange.Columns.Count
.Cells(1, y + 1) = "Concate"
lRow2 = .Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lRow2
.Cells(i, y + 1). = .Cells(i, 48) & .Cells(i, 3)
Next i
.Columns(y + 1).NumberFormat = "0"
End With
Set Target = Workbooks.Add
With Target.Sheets(1)
.Name = "ExistCells"
w = 1
For Each c In Source.Sheets(1).UsedRange.Columns(x + 1).Cells
For j = 2 To lRow2
If c.Value = Source2.Sheets(1).Cells(j, y + 1) Then
.Cells(w, 1).Value = Source2.Sheets(1).Cells(j, 48)
.Cells(w, 2).Value = Source2.Sheets(1).Cells(j, 3)
.Cells(w, 3).Value = Source2.Sheets(1).Cells(j, 27)
.Cells(w, 4).Value = Source2.Sheets(1).Cells(j, 41)
w = w + 1
Exit For
End If
Next j
Next c
End With
Source.Close SaveChanges:=False
Source2.Close SaveChanges:=False
Target.SaveAs FileName:= "C:\Reports\Target.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
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
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
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
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