I'm working my way through loops and naturally have started off with a challenging one! I have a workbook with multiple sheets. Each sheet has the operations to complete a "widget". I'm trying to walk through a range of cells and search by date to find a matching date. If that date matches, I want to add the std hours in row 7 of that column. I was able to make this work through brut force code and copy and paste my loop for each column. I REALLY DONT want to do this for all the columns on each tab.
I'm sure there is a way to use my counters for last row and last column to do a nested loop so once I complete the loop in one column, it moves to the next. I'm just not sure how to get there. Was hoping for some help on this! Thank you!
edit: essentially what I want to do is start in I12, loop to bottom of column looking for the date then counting the number of times I see that to add up the number of PPC hours (I7). Then, move to J12, loop to bottom of column, move to K12, loop to bottom adding up hours for Assy. Etc...
Sub Resource_Overview()
'Summary of daily tasks by worktype
'Declare the variables we'll need
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Dim i As Double 'for counters, using double to add up decimals
Dim Assy, Solder, QC, Weld, Test, PPC As Double 'variables to hold std hours total
Dim a As Long
Assy = 0#
Solder = 0#
QC = 0#
Weld = 0#
Test = 0#
PPC = 0#
'Find Last Row and Column
Set sht = ActiveSheet
Set StartCell = Range("I12")
LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = sht.Cells(StartCell.Row, sht.Columns.Count).End(xlToLeft).Column - 3 '-3 columns to not count need date or ECD info
Set sht = ActiveSheet
Set StartCell = Range("I12")
For i = 12 To LastRow
If Range("I" & i).Value = 44154 Then
If Range("I" & 1) = "Assy" Then
Assy = Assy + Range("I7").Value
ElseIf Range("I" & 1) = "Solder" Then
Solder = Solder + Range("I7").Value
ElseIf Range("I" & 1) = "Weld" Then
Weld = Weld + Range("I7").Value
ElseIf Range("I" & 1) = "Test" Then
Test = Test + Range("I7").Value
ElseIf Range("I" & 1) = "PPC" Then
PPC = PPC + Range("I7").Value
ElseIf Range("I" & 1) = "QC" Then
QC = QC + Range("I7").Value
End If
End If
Next i
For i = 12 To LastRow
If Range("J" & i).Value = 44154 Then
If Range("J" & 1) = "Assy" Then
Assy = Assy + Range("J7").Value
ElseIf Range("J" & 1) = "Solder" Then
Solder = Solder + Range("J7").Value
ElseIf Range("J" & 1) = "Weld" Then
Weld = Weld + Range("J7").Value
ElseIf Range("J" & 1) = "Test" Then
Test = Test + Range("J7").Value
ElseIf Range("J" & 1) = "PPC" Then
PPC = PPC + Range("J7").Value
ElseIf Range("J" & 1) = "QC" Then
QC = QC + Range("J7").Value
End If
End If
Next i
For i = 12 To LastRow
If Range("K" & i).Value = 44154 Then
If Range("K" & 1) = "Assy" Then
Assy = Assy + Range("K7").Value
ElseIf Range("K" & 1) = "Solder" Then
Solder = Solder + Range("K7").Value
ElseIf Range("K" & 1) = "Weld" Then
Weld = Weld + Range("K7").Value
ElseIf Range("K" & 1) = "Test" Then
Test = Test + Range("K7").Value
ElseIf Range("K" & 1) = "PPC" Then
PPC = PPC + Range("K7").Value
ElseIf Range("K" & 1) = "QC" Then
QC = QC + Range("K7").Value
End If
End If
Next i
For i = 12 To LastRow
If Range("L" & i).Value = 44154 Then
If Range("L" & 1) = "Assy" Then
Assy = Assy + Range("L7").Value
ElseIf Range("L" & 1) = "Solder" Then
Solder = Solder + Range("L7").Value
ElseIf Range("L" & 1) = "Weld" Then
Weld = Weld + Range("L7").Value
ElseIf Range("L" & 1) = "Test" Then
Test = Test + Range("L7").Value
ElseIf Range("L" & 1) = "PPC" Then
PPC = PPC + Range("L7").Value
ElseIf Range("L" & 1) = "QC" Then
QC = QC + Range("L7").Value
End If
End If
Next i
For i = 12 To LastRow
If Range("M" & i).Value = 44154 Then
If Range("M" & 1) = "Assy" Then
Assy = Assy + Range("L7").Value
ElseIf Range("M" & 1) = "Solder" Then
Solder = Solder + Range("M7").Value
ElseIf Range("M" & 1) = "Weld" Then
Weld = Weld + Range("M7").Value
ElseIf Range("M" & 1) = "Test" Then
Test = Test + Range("M7").Value
ElseIf Range("M" & 1) = "PPC" Then
PPC = PPC + Range("M7").Value
ElseIf Range("M" & 1) = "QC" Then
QC = QC + Range("M7").Value
End If
End If
Next i
Sheets("Sheet1").Select
Range("B2") = PPC
Range("B3") = Assy
Range("B4") = Solder
Range("B5") = QC
End Sub
So you can build your range:
Range(A1:D1) -> Range(Cells(A1), Cells(D1)) ->
Range(Cells(row number, column number), Cells(row number, column number)) ->
Range(Cells(1, 1), Cells(1, 4))
If the range is "A1". We can write either Range(Cells(1, 1), Cells(1, 1)) or use cell reference Cells(1,1).
To build ranges with loop you can replace some of the numbers with letters that represent the loop value, i.e. column/row number.
Without testing but I think you will get the logic:
Sub Resource_Overview()
'Summary of daily tasks by worktype
'Declare the variables we'll need
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Dim i As, j As Long 'I always use long
Dim Assy, Solder, QC, Weld, Test, PPC As Double 'variables to hold std hours total
Dim a As Long
Assy = 0#
Solder = 0#
QC = 0#
Weld = 0#
Test = 0#
PPC = 0#
'Find Last Row and Column
Set sht = ActiveSheet
Set StartCell = Range("I12")
LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = sht.Cells(StartCell.Row, sht.Columns.Count).End(xlToLeft).Column - 3 '-3 columns to not count need date or ECD info
Set sht = ActiveSheet
For i = 9 To LastColumn 'Set from which column number you want the loop to start from
For j = 12 To LastRow
If Cells(j,i).Value = 44154 Then
If Cells(1,i).Value = "Assy" Then
Assy = Assy + Cells(7,i).Value
ElseIf Cells(1,i).Value = "Solder" Then
Solder = Solder + Cells(7,i).Value
ElseIf Cells(1,i).Value = "Weld" Then
Weld = Weld + Cells(7,i).Value
ElseIf Cells(1,i).Value = "Test" Then
Test = Test + Cells(7,i).Value
ElseIf Cells(1,i).Value = "PPC" Then
PPC = PPC + Cells(7,i).Value
ElseIf Cells(1,i).Value = "QC" Then
QC = QC + Cells(7,i).Value
End If
End If
Next j
Next i
Sheets("Sheet1").Range("B2") = PPC
Sheets("Sheet1").Range("B3") = Assy
Sheets("Sheet1").Range("B4") = Solder
Sheets("Sheet1").Range("B5") = QC
End Sub
Related
I have the below code and find that copy-pasting is slow and the interior colour is slow as well.
I am trying to deal with this code with 700,000 rows + 120 columns of data.
Any suggestion to improve the speed.
Currently, it can take me more than 20 mins to finish this row of code.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayStatusBar = False
For i = keycolumns + 2 To ILcol + 1
'Result.Cells(1, resultcolumn).EntireColumn.Insert
rColumnLetter = Split(Cells(1, resultcolumn - 1).Address, "$")(1)
iColumnLetter = Split(Cells(1, i - 1).Address, "$")(1)
IL.Range(iColumnLetter & "1:" & iColumnLetter & ILrow).Copy Result.Range(rColumnLetter & "1:" & rColumnLetter & ILrow)
colNum = Application.WorksheetFunction.Match(Result.Cells(1, resultcolumn - 1).Value, PL.Range("1:1"), 0)
Result.Cells(1, resultcolumn) = Result.Cells(1, resultcolumn - 1) & " Postload - " & colNum
'Result.Cells(1, resultcolumn + 1).EntireColumn.Insert
Result.Cells(1, resultcolumn + 1) = Result.Cells(1, resultcolumn - 1) & " Comparison"
ColumnLetter = Split(Cells(1, resultcolumn + 1).Address, "$")(1)
Result.Range(ColumnLetter & "1:" & ColumnLetter & ILrow).Interior.Color = RGB(146, 208, 80)
resultcolumn = resultcolumn + (2 * (i - i + 1)) + 1
Next i
In my experience it is better to avoid operations directly on the sheets. What I would do is:
create an array variable
resize the array so it can hold all the data
populate the array with the actions currently included in your 'for' loop
print the array into the sheet
The final result would be close to this:
public sub populateArray()
dim arr_data() as Variant
dim numberOfRows,numberOfColumns,currentRow,currentCollumn as integer
currentRow = 0
currentCollumn = 0
numberOfRows = 10
numberOfColumns = 10
redim arr_data(numberOfRows,numberOfColumns)
for currentRow to numberOfRows
for currentCollumn to numberOfColumns
arr_data (currentRow,currentCollumn) = "TEXT"
next currentCollumn
next currentRow
with activesheet
.range("A1") = arr_data
next with
end sub
Please note that I did not test the above code, feel free to adjust it to your needs.
I have a for next loop that runs through a couple hundred thousand lines making changes on most. Could an array to make this code run faster?
The example of my for loop. Sometimes it gets overloaded and crashes Excel. (FYI my loop has to run bottom to top for it to do its intended purpose.)
Sub RemoveDuplicates()
Dim shWorkBook As Worksheet
Dim wkb As Workbook
Dim FullYearData As Worksheet
Set wkb = ThisWorkbook
With wkb
Set shWorkBook = .Sheets("Workbook")
Set shFullYearData = .Sheets("FullYearData")
End With
Dim i As Long
Dim LastRowW As Long
On Error Resume Next
Call TurnOffCalc
FirstRowW = shWorkBook.Cells(1, 1).Row
FirstColW = shWorkBook.Cells(1, 1).Column
LastRowW = shWorkBook.Cells(Rows.Count, 1).End(xlUp).Row
LastColW = shWorkBook.Cells(2, Columns.Count).End(xlToLeft).Column
i = LastRowW
Sum = 0
shWorkBook.Activate
For i = LastRowW To 1 Step -1
If shWorkBook.Cells(i, 7) = shWorkBook.Cells(i - 1, 7) Then
shWorkBook.Cells(i, 26) = vbNullString
End If
If shWorkBook.Cells(i, 26).Value <> "" Then
shWorkBook.Cells(i, 27) = Sum + Cells(i, 25).Value
Sum = 0
ElseIf shWorkBook.Cells(i, 26).Value = "" Then
Sum = shWorkBook.Cells(i, 25).Value + Sum
End If
Next
p = FirstRowW + 1
For p = FirstRowW + 1 To LastRowW Step 1
shWorkBook.Cells(p, 28) = Application.WeekNum(shWorkBook.Cells(p, 3))
Next
shWorkBook.Cells(1, 28).Value = "Week Number"
Call TurnOnCalc
End Sub
Try something like this:
Sub RemoveDuplicates()
Dim shWorkBook As Worksheet
Dim wkb As Workbook
Dim FullYearData As Worksheet
Dim i As Long, Sum
Dim LastRowW As Long, LastColW As Long, tbl As Range, data
Set wkb = ThisWorkbook
With wkb
Set shWorkBook = .Sheets("Workbook")
'Set shFullYearData = .Sheets("FullYearData")
End With
LastRowW = shWorkBook.Cells(Rows.Count, 1).End(xlUp).Row
LastColW = shWorkBook.Cells(2, Columns.Count).End(xlToLeft).Column
Set tbl = shWorkBook.Range("A1").Resize(LastRowW, 28) 'include "Week number" (?)
data = tbl.Value 'get the range value as an array
data(1, 28) = "Week Number"
Sum = 0
For i = LastRowW To 1 Step -1
If data(i, 7) = data(i - 1, 7) Then data(i, 26) = vbNullString
If data(i, 26).Value <> "" Then
data(i, 27) = Sum + data(i, 25).Value
Sum = 0
Else
Sum = data(i, 25).Value + Sum
End If
If i > 1 Then data(i, 28) = CLng(Format(data(i, 3), "ww"))
Next
tbl.Value = data 'return the data
End Sub
By no means, I am an experienced coder, but do need assistance with the following task.
I have a medium size to a large dataset that grows by rows with a fixed no. columns (81), for later distribution (no pivot tbl and/or formulas).
The below is the code that has so far able to achieve:
Declare all arrays by month populated from the dataset, create 1D array to add all columns and later paste transposed into the MONTH wksht.
and stuck on pasting past JAN
Thanks in advance
Sub RangeSize2()
Application.ScreenUpdating = False
Dim ws1 As Worksheet
Dim ws3 As Worksheet
Dim FinalSelection As Range, LRs3, LCs3 As Long, X As Integer
Dim Rx1, Rx2, Rx3, Rx4, Rx5, Rx6, Rx7, Rx8, Rx9, Rx10, Rx11, Rx12, Ry1, Ry2, Ry3, Ry4, Ry5, Ry6, Ry7, Ry8, Ry9, Ry10, Ry11, Ry12 As Long
Dim monthnames() As Variant
monthnames = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
Dim arrJAN(), arrFEB(), arrMAR() As Variant
Dim RG01, RG02, RG03, RG04, RG05, RG06, RG07, RG08, RG09, RG10, RG11, RG12 As Range
Dim c As Range, v As String
Set ws1 = ThisWorkbook.Worksheets("MONTH")
Set ws3 = ThisWorkbook.Worksheets("DATA")
LRs3 = Sheets("DATA").Cells(Rows.count, "A").End(xlUp).Row
LCs3 = Sheets("DATA").Cells(3, Columns.count).End(xlToLeft).Column
Cells(4, 1).Select
Sheets("DATA").Select
For X = 1 To 12
For Each c In Intersect(ActiveSheet.UsedRange, Range("B:B"))
If c.Value = monthnames(X) Then
v = c.Value '= v
If FinalSelection Is Nothing Then
Set FinalSelection = Range(Cells(c.Row, 1), Cells(c.Row, LCs3))
Else
Set FinalSelection = Union(FinalSelection, Range(Cells(c.Row, 1), Cells(c.Row, LCs3)))
End If
End If
Next c
''msgBox v
If Not FinalSelection Is Nothing Then FinalSelection.Select
If X = 1 Then
Ry1 = FinalSelection.Rows.count + FinalSelection.Row - 1
Rx1 = FinalSelection.Row
'msgBox v & " - " & Rx1 & " - " & Ry1
End If
If X = 2 Then
Ry2 = FinalSelection.Rows.count + FinalSelection.Row - 1
Rx2 = Ry1 + 1
'msgBox v & " - " & Rx2 & " - " & Ry2
End If
If X = 3 Then
Ry3 = FinalSelection.Rows.count + FinalSelection.Row - 1
Rx3 = Ry2 + 1
'msgBox v & " - " & Rx3 & " - " & Ry3
End If
If X = 4 Then
Ry4 = FinalSelection.Rows.count + FinalSelection.Row - 1
Rx4 = Ry3 + 1
'msgBox v & " - " & Rx4 & " - " & Ry4
End If
If X = 5 Then
Ry5 = FinalSelection.Rows.count + FinalSelection.Row - 1
Rx5 = Ry4 + 1
'msgBox v & " - " & Rx5 & " - " & Ry5
End If
If X = 6 Then
Ry6 = FinalSelection.Rows.count + FinalSelection.Row - 1
Rx6 = Ry5 + 1
'msgBox v & " - " & Rx6 & " - " & Ry6
End If
If X = 7 Then
Ry7 = FinalSelection.Rows.count + FinalSelection.Row - 1
Rx7 = Ry6 + 1
'msgBox v & " - " & Rx7 & " - " & Ry7
End If
If X = 8 Then
Ry8 = FinalSelection.Rows.count + FinalSelection.Row - 1
Rx8 = Ry7 + 1
'msgBox v & " - " & Rx8 & " - " & Ry8
End If
If X = 9 Then
Ry9 = FinalSelection.Rows.count + FinalSelection.Row - 1
Rx9 = Ry8 + 1
'msgBox v & " - " & Rx9 & " - " & Ry9
End If
If X = 10 Then
Ry10 = FinalSelection.Rows.count + FinalSelection.Row - 1
Rx10 = Ry9 + 1
'msgBox v & " - " & Rx10 & " - " & Ry10
End If
If X = 11 Then
Ry11 = FinalSelection.Rows.count + FinalSelection.Row - 1
Rx11 = Ry10 + 1
'msgBox v & " - " & Rx11 & " - " & Ry11
End If
If X = 12 Then
Ry12 = FinalSelection.Rows.count + FinalSelection.Row - 1
Rx12 = Ry11 + 1
'msgBox v & " - " & Rx12 & " - " & Ry12
End If
Next X
'RG01, RG02, RG03, RG04, RG05, RG06, RG07, RG08, RG09, RG10, RG11, RG12
'''''''''''''''''''''''''''''''looping & pasting each range
Dim RR As Long, CC As Long
Dim TotalCol As Double
'JAN''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ws3.Activate
RG01 = ws3.Range(Cells(Rx1, 1), Cells(Ry1, LCs3)).Value2
arrJAN = RG01
Dim JANTotal() As Variant
ReDim JANTotal(1 To LCs3)
TotalCol = 0
For CC = 1 To LCs3
For RR = 1 To UBound(arrJAN, 1)
On Error Resume Next
TotalCol = TotalCol + arrJAN(RR, CC)
JANTotal(CC) = TotalCol
Next RR
TotalCol = 0
Next CC
ws1.Activate
'paste to MONT SHt
ws1.Range(Cells(4, 3), Cells(LCs3 + 3, 3)) = Application.Transpose(JANTotal)
' Erase arrJAN
' Erase JANTotal
RR = 0
CC = 0
'FEB''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ws3.Activate
RG02 = ws3.Range(Cells(Rx2, 1), Cells(Ry2, LCs3)).Value2
RG02 = arrFEB
Dim FEBTotal() As Variant
ReDim FEBTotal(1 To LCs3)
TotalCol = 0
For CC = 1 To LCs3
For RR = 1 To UBound(arrFEB, 1)
On Error Resume Next
TotalCol = TotalCol + arrFEB(RR, CC)
FEBTotal(CC) = TotalCol
Next RR
TotalCol = 0
Next CC
ws1.Activate
'paste to MONT SHt
ws1.Range(Cells(4, 4), Cells(LCs3 + 3, 4)) = Application.Transpose(FEBTotal)
' Erase arrFEB
Application.ScreenUpdating = True
End Sub
There may be multiple issues in the code. One is obviously RG02 = arrFEB, think it would be arrFEB=RG02. But why go for such an overkill. Why not use something simple as below
Option Base 1
Sub test()
Dim ws1 As Worksheet
Dim ws3 As Worksheet
Dim Rng, smRng, CrtRng As Range, LRs3, LCs3, Cl As Long, M As Integer, V As String, Sm As Double
Dim monthnames() As Variant
monthnames = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
Set ws1 = ThisWorkbook.Worksheets("MONTH")
Set ws3 = ThisWorkbook.Worksheets("DATA")
LRs3 = ws3.Cells(Rows.Count, "A").End(xlUp).Row
LCs3 = ws3.Cells(3, Columns.Count).End(xlToLeft).Column
Set Rng = ws3.Range(ws3.Cells(1, 1), ws3.Cells(LRs3, LCs3))
Set CrtRng = ws3.Range(ws3.Cells(1, 2), ws3.Cells(LRs3, 2))
'MsgBox Rng.Address
For M = 1 To 12
V = monthnames(M)
For Cl = 1 To LCs3
Set smRng = ws3.Range(ws3.Cells(1, Cl), ws3.Cells(LRs3, Cl))
If Cl <> 2 Then
Sm = Application.WorksheetFunction.SumIf(CrtRng, V, smRng)
'ws3.Cells(LRs3 + 2 + M, Cl).Value = Sm ' for checking below data range by applying data filter
ws1.Cells(3 + Cl, 2 + M).Value = Sm
Else
'ws3.Cells(LRs3 + 2 + M, Cl).Value = V ' for checking below data range by applying data filter
ws1.Cells(3 + Cl, 2 + M).Value = V
End If
Next Cl
Next M
End Sub
Hope it will be useful.
Problem
How can you horizontally align values in separate columns, and apply a dynamic formula? Preemptive thank you for any help or clues! The code pasted below works, in so far as it reaches halfway to the end destination. But how to accomplish the last two objectives?
1) Sum each range
2) Align the ranges horizontally
A sample sheet containing customer id, item and prices. Sales from Monday on the left, Tuesday on the right.
Current results
Desired results
Align cust id on rows A and E, with an associated sum. Notice how each yellow line contains cust id for identification, as well as associated Sum total.
Existing VBA Code
Sub AlignAndMatch()
'backup sheet
ActiveSheet.Copy after:=Sheets(Sheets.Count)
'Insert rows where current cell <> cell above
Dim i, totalrows As Integer
Dim strRange As String
Dim strRange2 As String
'----------------------------------------
'Monday sort table
Range("A2:C65536").Select
Selection.Sort Key1:=Range("A2:C65536"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Monday insert loop
totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row
i = 0
Do While i <= totalrows
i = i + 1
strRange = "A" & i
strRange2 = "A" & i + 1
If Range(strRange).Text <> Range(strRange2).Text Then
Range(Cells(i + 1, 1), Cells(i + 2, 3)).Insert xlDown 'think cells ~A1:C2 insert
totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row
i = i + 2 'for insert 2 rows
End If
Loop
'Monday footer row loop
totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(0, 0).Row
i = 0
Do While i <= totalrows
i = i + 1
If IsEmpty(Range("A" & i).Value) And Not IsEmpty(Range("A" & i + 1).Value) Then
Range("A" & i).Value = Range("A" & i + 1).Value
Range("B" & i).Value = "Sum"
End If
Loop
'----------------------------------------
'Tuesday sort table
Range("E2:G65536").Select
Selection.Sort Key1:=Range("E2:G65536"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Tuesday insert loop
totalrows = ActiveSheet.Range("E65536").End(xlUp).Offset(0, 0).Row
i = 0
Do While i <= totalrows
i = i + 1
strRange = "E" & i
strRange2 = "E" & i + 1
If Range(strRange).Text <> Range(strRange2).Text Then
Range(Cells(i + 1, 5), Cells(i + 2, 7)).Insert xlDown 'think cells ~A1:C2 insert
totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row
i = i + 2 'for insert 2 rows
End If
Loop
'Tuesday footer row loop
totalrows = ActiveSheet.Range("E65536").End(xlUp).Offset(0, 0).Row
i = 0
Do While i <= totalrows
i = i + 1
If IsEmpty(Range("E" & i).Value) And Not IsEmpty(Range("E" & i + 1).Value) Then
Range("E" & i).Value = Range("E" & i + 1).Value
Range("F" & i).Value = "Sum"
End If
Loop
End Sub
If I needed something like that I might think twice what I want and why: if the original day lists don't come from somehwere, you could put everything into one list and make some pivots...
But. Here's some idea, playing with the arrays again and there's probably work to do, but does this help:
Option Base 1
Sub ReLists()
Dim ListSheet As Worksheet
Dim DayCorners() As Range
Dim Day()
Dim Days As Integer
Dim CustIDs()
Dim CustomerRow() 'for placement in the final list
Dim DayList()
Dim MaxCustIDs As Integer
Dim NewCustID As Boolean
Days = 2
MaxCustIDs = 5
ReDim DayCorners(Days)
ReDim Day(Days)
ReDim CustomerRow(MaxCustIDs + 2)
CustomerRow(1) = 0
ReDim CustIDs(MaxCustIDs)
ReDim DayItems(1, 1)
Set ListSheet = Worksheets("Sheet1")
Set DayCorners(1) = ListSheet.Range("A2")
Set DayCorners(2) = ListSheet.Range("E2")
For d = 1 To Days
With ListSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=DayCorners(d)
.SetRange Range(DayCorners(d), DayCorners(d).End(xlDown).Offset(0, 2))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
Day(d) = Range(DayCorners(d), DayCorners(d).End(xlDown).Offset(0, 2))
If UBound(Day(d), 1) > UBound(DayItems, 2) Then
ReDim DayItems(Days, UBound(Day(d)))
End If
Next d
CustIDCount = 0
For d = 1 To Days
For r = 1 To UBound(Day(d), 1)
NewCustID = True
For u = 1 To UBound(CustIDs)
If CustIDs(u) = Day(d)(r, 1) Then NewCustID = False
Next u
If NewCustID Then
CustIDCount = CustIDCount + 1
CustIDs(CustIDCount) = Day(d)(r, 1)
End If
Next r
Next d
With Worksheets.Add(After:=Worksheets(ListSheet.Index))
Set DayCorners(1) = .Range("A2")
Set DayCorners(2) = .Range("E2")
End With
ReDim DayList(Days, CustIDCount, 100, 3)
For d = 1 To Days
For c = 1 To CustIDCount
rc = 1
For r = 1 To UBound(Day(d), 1)
If Day(d)(r, 1) = CustIDs(c) Then
DayList(d, c, rc, 1) = Day(d)(r, 1)
DayList(d, c, rc, 2) = Day(d)(r, 2)
DayList(d, c, rc, 3) = Day(d)(r, 3)
rc = rc + 1
End If
Next r
If CustomerRow(c) + rc + 2 > CustomerRow(c + 1) Then
CustomerRow(c + 1) = CustomerRow(c) + rc + 1
End If
Next c
If CustomerRow(c - 1) + rc + 2 > CustomerRow(c) Then
CustomerRow(c) = CustomerRow(c) + rc
End If
Next d
For d = 1 To Days
With DayCorners(d).Offset(-1, 0).Range("A1:C1")
.Value = Array("cust id", "item", "Price")
'formatting
End With
For c = 1 To CustIDCount
SumFormula = "=SUM(R[1]C:R[" & (CustomerRow(c + 1) - CustomerRow(c) - 1) & "]C)"
With DayCorners(d).Offset(CustomerRow(c), 0).Range("A1:D1")
If Not IsEmpty(DayList(d, c, 1, 1)) Then
.Value = Array(CustIDs(c), "Sum", SumFormula, "")
End If
.Interior.Color = 65535
End With
For rc = 1 To UBound(Day(d), 1)
If IsEmpty(DayList(d, c, rc, 1)) Then Exit For
DayCorners(d).Offset(CustomerRow(c) + rc, 0) = DayList(d, c, rc, 1)
DayCorners(d).Offset(CustomerRow(c) + rc, 1) = DayList(d, c, rc, 2)
DayCorners(d).Offset(CustomerRow(c) + rc, 2) = DayList(d, c, rc, 3)
Next rc
Next c
Next d
End Sub
I believe the solution is to simulate an SQL full outer join, via VBA. I'll start hacking away at it. Should be a fun personal challenge. I'll try to update this answer once I find the final solution.
The direction I'm following is here.
I have written a VBA Macro which works, but takes too long because the database is also very big.
I know this can be optimized via Arrays, but I am not sure how to make it.
Could someone help me please?
'Identify how many rows are in the file
finalrow = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row
'fill the empty fields which requires the part number and description
For i = 2 To finalrow
If Cells(i, 3) = 0 Or Cells(i, 3) = "------------" Or Cells(i, 3) = "e" Or Cells(i, 3) = "111)" Or Cells(i, 3) = "ion" Then
If Cells(i, 4) = 0 Or Cells(i, 4) = "-----------" Or Cells(i, 4) = "Location" Then
Range("A" & i & ":H" & i).Select
Selection.Delete Shift:=xlUp
i = i - 1
Else
For j = 1 To 3
Cells(i, j) = Cells(i - 1, j)
Next
End If
End If
If Cells(i, 1) = 0 Then
Cells(i, 1) = Cells(i - 1, 1)
End If
If Cells(i, 4) = 0 Then
Range("A" & i & ":H" & i).Select
Selection.Delete Shift:=xlUp
i = i - 1
End If
Count = Count + 1
If Count = finalrow Then
i = finalrow
End If
Next
I combined your code with my answer to excel Delete rows from table Macro based on criteria, that I just finished posting. It is super fast. Please check out my other answer for details.
You may need to adjust the Target range. If your data starts in A1 and does not have any completely blank rows than it should work.
Sub DeleteRows()
Dim Start: Start = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Const PreserveFormulas As Boolean = True
Dim Target As Range
Dim DeleteRow As Boolean
Dim Data, Formulas, NewData
Dim pos As Long, x As Long, y As Long
Set Target = Range("A1").CurrentRegion
Data = Target.Value
If PreserveFormulas Then Formulas = Target.Formula
ReDim NewData(1 To UBound(Data, 1), 1 To UBound(Data, 2))
For x = 2 To UBound(Data, 1)
DeleteRow = True
If Data(x, 3) = 0 Or Data(x, 3) = "------------" Or Data(x, 3) = "e" Or Data(x, 3) = "111)" Or Data(x, 3) = "ion" Then
If Data(x, 4) = 0 Or Data(x, 4) = "-----------" Or Data(x, 4) = "Location" Then
DeleteRow = False
End If
End If
If Data(x, 4) = 0 Or Data(x, 4) = "-----------" Or Data(x, 4) = "Location" Then DeleteRow = False
If Not DeleteRow Then
pos = pos + 1
For y = 1 To UBound(Data, 2)
If PreserveFormulas Then
NewData(pos, y) = Formulas(x, y)
Else
NewData(pos, y) = Data(x, y)
End If
Next
End If
Next
Target.Formula = NewData
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print "Execution Time: "; Timer - Start; " Second(s)"
End Sub
I'd start simply with this:
'Identify how many rows are in the file
finalrow = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row
'fill the empty fields which requires the part number and description
For i = 2 To finalrow
Set ci3 = Cells(i, 3)
If ci3 = 0 Or ci3 = "------------" Or ci3 = "e" Or ci3 = "111)" Or ci3 = "ion" Then
Set ci4 = Cells(i, 4)
If ci4 = 0 Or ci4 = "-----------" Or ci4 = "Location" Then
Range("A" & i & ":H" & i).Select
Selection.Delete Shift:=xlUp
i = i - 1
Else
For j = 1 To 3
Cells(i, j) = Cells(i - 1, j)
Next
End If
End If
If Cells(i, 1) = 0 Then
Cells(i, 1) = Cells(i - 1, 1)
End If
If Cells(i, 4) = 0 Then
Range("A" & i & ":H" & i).Select
Selection.Delete Shift:=xlUp
i = i - 1
End If
Count = Count + 1
If Count = finalrow Then
i = finalrow
End If
Next