I have this below change event macro The purpose of the macro is to prepare a quote master for the items entered. The data to be entered in the cells starting B15( which is for the item number) and E15(which is for the quantity) The workbook is having 3 additional sheets Stocklist5104(A: Item number, B: Description, C:Quantity) Stocklist5102(A: Item number, B: Description, C:Quantity) PriceList(A: PN, B: Supersede, C: Part Name, D: Stock, E: COST, F: Sale Price, G: Remarks, H: TAG, I: , J: P0, K: P1, L: P2, M: P3, N: P4)
Once the data is entered in B15, all other cells till T will be populated with these formulas. I have placed two sections, in which the user can enter data manually one by one or else can copy paste a set of values to the column B starting B15.
Everything works fine, but I want to check if I have made this macro complicated to make it run slow. The data entering in B column can be either 1 or 1000 at same time.
adding the full code for better undertstanding.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B:B")) Is Nothing Then
If Not Application.CutCopyMode And IsSelectionNotEmptyOrNumeric(Target) Then ' Check if cell contains a numeric value or is not empty and the change was made by the user
If Target.Cells.Count > 1 Then ' Check if multiple cells are selected
Dim deleteRows As Range ' Create a range object to store rows to delete
Dim lastrow As Long
For Each cell In Target.Cells
If cell.Value <> "" Then
UnProtectSheet
Application.Calculation = xlCalculationManual
Range("A" & cell.row).Value = "=IFERROR(IF(B" & cell.row & "<>"""",ROW()-ROW($A$15)+1,""""),0)"
Range("H" & cell.row).Value = "=IFERROR(IF(B" & cell.row & "<>"""",G" & cell.row & "*F" & cell.row & ",""""),0)"
Range("D" & cell.row).Value = "=IFERROR(INDEX(PriceList!$C$4:$C$7956,MATCH(B" & cell.row & ",PriceList!$A$4:$A$7956,0)),"""")"
Range("G" & cell.row).FormulaR1C1 = "=IFERROR(INDEX(PriceList!R4C9:R10000C14,IFERROR(MATCH(RC[-5],PriceList!R4C1:R10000C1,0),MATCH(RC[-4],PriceList!R4C1:R10000C1,0)),MATCH(Customer_Database!R3C3,{""P1"",""P2"",""P3"",""P4"",""P5"",""P0""},0)),"""")"
Range("F" & cell.row).Value = "=IFERROR(IF($AA$1=2,IF(E" & cell.row & ">INDEX(StockList5104!$C$2:$C$7956,MATCH(B" & cell.row & ",StockList5104!$A$2:$A$7956,0)),INDEX(StockList5104!$C$2:$C$7956,MATCH(B" & cell.row & ",StockList5104!$A$2:$A$7956,0)),E" & cell.row & "),IF(E" & cell.row & ">INDEX(StockList5102!$C$2:$C$7956,MATCH(B" & cell.row & ",StockList5102!$A$2:$A$7956,0)),INDEX(StockList5102!$C$2:$C$7956,MATCH(B" & cell.row & ",StockList5102!$A$2:$A$7956,0)),E" & cell.row & ")),0)"
Range("I" & cell.row).Value = "=IFERROR(IF($AA$1=2,INDEX(StockList5104!$C$2:$C$7956,MATCH(B" & cell.row & ",StockList5104!$A$2:$A$7956,0)),INDEX(StockList5102!$C$2:$C$7956,MATCH(B" & cell.row & ",StockList5102!$A$2:$A$7956,0))),0)"
Range("K" & cell.row).Value = "=IFERROR(INDEX(PriceList!$E$4:$E$7956,MATCH(B" & cell.row & ",PriceList!$A$4:$A$7956,0)),0)"
Range("J" & cell.row).Value = "=IFERROR(IF(B" & cell.row & "<>"""",K" & cell.row & "*F" & cell.row & ",""""),0)"
Range("L" & cell.row).Value = "=IFERROR(IF($AA$2=2,IF(B" & cell.row & "<>"""",G" & cell.row & "/K" & cell.row & "-1,""""),IF(B" & cell.row & "<>"""",(G" & cell.row & "/K" & cell.row & "-1)-5%,"""")),0)"
Range("N" & cell.row).Value = "=IFERROR(IF($AA$2=2,IF(B" & cell.row & "<>"""",M" & cell.row & "/K" & cell.row & "-1,""""),IF(B" & cell.row & "<>"""",(M" & cell.row & "/K" & cell.row & "-1)-5%,"""")),0)"
Range("O" & cell.row).Value = "=IFERROR(IF(B" & cell.row & "<>"""",M" & cell.row & "*F" & cell.row & ",""""),0)"
Range("Q" & cell.row).Value = "=IFERROR(IF($AA$2=2,IF(B" & cell.row & "<>"""",P" & cell.row & "/K" & cell.row & "-1,""""),IF(B" & cell.row & "<>"""",(P" & cell.row & "/K" & cell.row & "-1)-5%,"""")),0)"
Range("R" & cell.row).Value = "=IFERROR(IF(B" & cell.row & "<>"""",P" & cell.row & "*F" & cell.row & ",""""),0)"
Range("S" & cell.row).Value = "=IFERROR(INDEX(PriceList!$G$4:$G$7956,MATCH(B" & cell.row & ",PriceList!$A$4:$A$7956,0)),"""")"
Range("T" & cell.row).Value = "=IFERROR(INDEX(PriceList!$H$4:$H$7956,MATCH(B" & cell.row & ",PriceList!$A$4:$A$7956,0)),"""")"
Application.Calculation = xlCalculationAutomatic
' Set horizontal alignment and formatting for the cells
With Range("A" & cell.row)
.HorizontalAlignment = xlCenter
End With
With Range("B" & cell.row & ":D" & cell.row)
.HorizontalAlignment = xlLeft
End With
Dim rng1 As Range
Set rng1 = Union(Range("E" & cell.row), Range("F" & cell.row), Range("I" & cell.row), Range("H8:H10"))
With rng1
.HorizontalAlignment = xlCenter
.NumberFormat = "0"
End With
With Range("M" & cell.row)
.Interior.Color = RGB(146, 2089, 80)
End With
Dim rng2 As Range
Set rng2 = Union(Range("G" & cell.row), Range("H" & cell.row), Range("J" & cell.row), _
Range("K" & cell.row), Range("M" & cell.row), Range("O" & cell.row), Range("P" & cell.row), Range("R" & cell.row), _
Range("H11"), Range("M6"), Range("M8"), Range("M10"))
With rng2
.NumberFormat = "0.00_-;[Red]-0.00_-;""-""??_-;@"
.HorizontalAlignment = xlRight
End With
Dim rng3 As Range
Set rng3 = Union(Range("N" & cell.row), Range("L" & cell.row), Range("Q" & cell.row), Range("M7"), _
Range("M9"), Range("M11"))
With rng3
.HorizontalAlignment = xlRight
.NumberFormat = "0.00%"
End With
' Copy border, border color and orientation from row above
With Range("A" & cell.row & ":T" & cell.row)
.Borders.LineStyle = .Offset(-1, 0).Borders.LineStyle
.Borders.Color = .Offset(-1, 0).Borders.Color
.Orientation = .Offset(-1, 0).Orientation
.HorizontalAlignment = .Offset(-1, 0).HorizontalAlignment
End With
ProtectSheet
Else
' Add row to deleteRows range
If deleteRows Is Nothing Then
Set deleteRows = Rows.Item(cell.row)
Else
Set deleteRows = Union(deleteRows, Rows.Item(cell.row))
End If
End If
Next cell
UnProtectSheet
'Formatting of the Header cells
With Range("H8:H10")
.HorizontalAlignment = xlCenter
.NumberFormat = "0"
End With
With Range("H11")
.HorizontalAlignment = xlCenter
.NumberFormat = "0.00_-;[Red]-0.00_-;""-""??_-;@"
End With
Application.Calculation = xlCalculationManual
'Calculations for the header cells
lastrow = Cells.Item(Rows.Count, "B").End(xlUp).row
Range("H6").Value = "=TODAY()"
Range("H9").Value = "=IFERROR(SUM(E15:E" & lastrow & "),"""")"
Range("H8").Value = Application.WorksheetFunction.CountA(Range("B15:B" & Cells.Item(Rows.Count, "B").End(xlUp).row))
Range("H10").Value = "=IFERROR(SUM(F15:F" & Cells.Item(Rows.Count, "F").End(xlUp).row & "),"""")"
Range("H11").Value = "=IFERROR(ROUND(SUM(H15:H" & Cells.Item(Rows.Count, "H").End(xlUp).row & "),2),"""")"
Range("M6").Value = "=IFERROR(ROUND(SUM(J15:J" & Cells.Item(Rows.Count, "J").End(xlUp).row & "),2),"""")"
Range("M7").Value = "=IFERROR(IF($AA$2=2,ROUND(H11/M6-1,2),ROUND((H11/M6-1)-5%,2)),"""")"
Range("M8").Value = "=IFERROR(ROUND(SUM(O15:O" & Cells.Item(Rows.Count, "O").End(xlUp).row & "),2),"""")"
Range("M9").Value = "=IFERROR(IF($AA$2=2,ROUND(M8/M6-1,2),ROUND((M8/M6-1)-5%,2)),"""")"
Range("M10").Value = "=IFERROR(ROUND(SUM(R15:R" & Cells.Item(Rows.Count, "R").End(xlUp).row & "),2),"""")"
Range("M11").Value = "=IFERROR(IF($AA$2=2,ROUND(M10/M6-1,2),ROUND((M10/M6-1)-5%,2)),"""")"
Application.Calculation = xlCalculationAutomatic
ProtectSheet
' Delete entire rows in deleteRows range
If Not deleteRows Is Nothing Then
UnProtectSheet
Application.EnableEvents = False ' Disable events to avoid triggering the event again
deleteRows.Delete
Application.EnableEvents = True ' Enable events again
ProtectSheet
End If
Else
If Target.Value <> "" Then
UnProtectSheet
Debug.Print Target
Debug.Print Target.row
Range("A" & Target.row).Value = "=IFERROR(IF(B" & Target.row & "<>"""",ROW()-ROW($A$15)+1,""""),0)"
Range("D" & Target.row).Value = "=IFERROR(INDEX(PriceList!$C$4:$C$7956,MATCH(B" & Target.row & ",PriceList!$A$4:$A$7956,0)),"""")"
Range("F" & Target.row).Value = "=IFERROR(IF($AA$1=2,IF(E" & Target.row & ">INDEX(StockList5104!$C$2:$C$7956,MATCH(B" & Target.row & ",StockList5104!$A$2:$A$7956,0)),INDEX(StockList5104!$C$2:$C$7956,MATCH(B" & Target.row & ",StockList5104!$A$2:$A$7956,0)),E" & Target.row & "),IF(E" & Target.row & ">INDEX(StockList5102!$C$2:$C$7956,MATCH(B" & Target.row & ",StockList5102!$A$2:$A$7956,0)),INDEX(StockList5102!$C$2:$C$7956,MATCH(B" & Target.row & ",StockList5102!$A$2:$A$7956,0)),E" & Target.row & ")),0)"
Range("G" & Target.row).FormulaR1C1 = "=IFERROR(INDEX(PriceList!R4C9:R10000C14,IFERROR(MATCH(RC[-5],PriceList!R4C1:R10000C1,0),MATCH(RC[-4],PriceList!R4C1:R10000C1,0)),MATCH(Customer_Database!R3C3,{""P1"",""P2"",""P3"",""P4"",""P5"",""P0""},0)),"""")"
Range("H" & Target.row).Value = "=IFERROR(IF(B" & Target.row & "<>"""",G" & Target.row & "*F" & Target.row & ",""""),0)"
Range("I" & Target.row).Value = "=IFERROR(IF($AA$1=2,INDEX(StockList5104!$C$2:$C$7956,MATCH(B" & Target.row & ",StockList5104!$A$2:$A$7956,0)),INDEX(StockList5102!$C$2:$C$7956,MATCH(B" & Target.row & ",StockList5102!$A$2:$A$7956,0))),0)"
Range("J" & Target.row).Value = "=IFERROR(IF(B" & Target.row & "<>"""",K" & Target.row & "*F" & Target.row & ",""""),0)"
Range("K" & Target.row).Value = "=IFERROR(INDEX(PriceList!$E$4:$E$7956,MATCH(B" & Target.row & ",PriceList!$A$4:$A$7956,0)),0)"
Range("L" & Target.row).Value = "=IFERROR(IF($AA$2=2,IF(B" & Target.row & "<>"""",G" & Target.row & "/K" & Target.row & "-1,""""),IF(B" & Target.row & "<>"""",(G" & Target.row & "/K" & Target.row & "-1)-5%,"""")),0)"
Range("N" & Target.row).Value = "=IFERROR(IF($AA$2=2,IF(B" & Target.row & "<>"""",M" & Target.row & "/K" & Target.row & "-1,""""),IF(B" & Target.row & "<>"""",(M" & Target.row & "/K" & Target.row & "-1)-5%,"""")),0)"
Range("O" & Target.row).Value = "=IFERROR(IF(B" & Target.row & "<>"""",M" & Target.row & "*F" & Target.row & ",""""),0)"
Range("Q" & Target.row).Value = "=IFERROR(IF($AA$2=2,IF(B" & Target.row & "<>"""",P" & Target.row & "/K" & Target.row & "-1,""""),IF(B" & Target.row & "<>"""",(P" & Target.row & "/K" & Target.row & "-1)-5%,"""")),0)"
Range("R" & Target.row).Value = "=IFERROR(IF(B" & Target.row & "<>"""",P" & Target.row & "*F" & Target.row & ",""""),0)"
Range("S" & Target.row).Value = "=IFERROR(INDEX(PriceList!$G$4:$G$7956,MATCH(B" & Target.row & ",PriceList!$A$4:$A$7956,0)),"""")"
Range("T" & Target.row).Value = "=IFERROR(INDEX(PriceList!$H$4:$H$7956,MATCH(B" & Target.row & ",PriceList!$A$4:$A$7956,0)),"""")"
' Set horizontal alignment
With Range("A" & Target.row)
.HorizontalAlignment = xlCenter
End With
With Range("B" & Target.row & ":D" & Target.row)
.HorizontalAlignment = xlLeft
End With
With Range("M" & Target.row)
.Interior.Color = RGB(146, 2089, 80)
End With
Dim rnge1 As Range
Set rnge1 = Union(Range("E" & Target.row), Range("F" & Target.row), Range("I" & Target.row), Range("H8:H10"))
With rnge1
.HorizontalAlignment = xlCenter
.NumberFormat = "0"
End With
Dim rnge2 As Range
Set rnge2 = Union(Range("G" & Target.row), Range("H" & Target.row), Range("J" & Target.row), _
Range("K" & Target.row), Range("M" & Target.row), Range("O" & Target.row), Range("P" & Target.row), Range("R" & Target.row), _
Range("H11"), Range("M6"), Range("M8"), Range("M10"))
With rnge2
.NumberFormat = "0.00_-;[Red]-0.00_-;""-""??_-;@"
.HorizontalAlignment = xlRight
End With
Dim rnge3 As Range
Set rnge3 = Union(Range("N" & Target.row), Range("L" & Target.row), Range("Q" & Target.row), Range("M7"), Range("M9"), Range("M11"))
With rnge3
.HorizontalAlignment = xlRight
.NumberFormat = "0.00%"
End With
' Copy border, border color and orientation from row above
With Range("A" & Target.row & ":T" & Target.row)
.Borders.LineStyle = .Offset(-1, 0).Borders.LineStyle
.Borders.Color = .Offset(-1, 0).Borders.Color
.Orientation = .Offset(-1, 0).Orientation
.HorizontalAlignment = .Offset(-1, 0).HorizontalAlignment
End With
Application.Calculation = xlCalculationManual
lastrow = Cells.Item(Rows.Count, "B").End(xlUp).row
Range("H6").Value = "=TODAY()"
Range("H8").Value = Application.WorksheetFunction.CountA(Range("B15:B" & Cells.Item(Rows.Count, "B").End(xlUp).row))
Range("H9").Value = "=IFERROR(SUM(E15:E" & lastrow & "),"""")"
Range("H10").Value = "=IFERROR(SUM(F15:F" & Cells.Item(Rows.Count, "F").End(xlUp).row & "),"""")"
Range("H11").Value = "=IFERROR(ROUND(SUM(H15:H" & Cells.Item(Rows.Count, "H").End(xlUp).row & "),2),"""")"
Range("M6").Value = "=IFERROR(ROUND(SUM(J15:J" & Cells.Item(Rows.Count, "J").End(xlUp).row & "),2),"""")"
Range("M7").Value = "=IFERROR(IF($AA$2=2,ROUND(H11/M6-1,2),ROUND((H11/M6-1)-5%,2)),"""")"
Range("M8").Value = "=IFERROR(ROUND(SUM(O15:O" & Cells.Item(Rows.Count, "O").End(xlUp).row & "),2),"""")"
Range("M9").Value = "=IFERROR(IF($AA$2=2,ROUND(M8/M6-1,2),ROUND((M8/M6-1)-5%,2)),"""")"
Range("M10").Value = "=IFERROR(ROUND(SUM(R15:R" & Cells.Item(Rows.Count, "R").End(xlUp).row & "),2),"""")"
Range("M11").Value = "=IFERROR(IF($AA$2=2,ROUND(M10/M6-1,2),ROUND((M10/M6-1)-5%,2)),"""")"
Application.Calculation = xlCalculationAutomatic
ProtectSheet
Else
' Delete entire row
UnProtectSheet
Application.EnableEvents = False ' Disable events to avoid triggering the event again
Rows.Item(Target.row).Delete
Application.EnableEvents = True ' Enable events again
ProtectSheet
End If
End If
End If
End If
' Protect the worksheet again if it was previously protected
End Sub
Private Function IsSelectionNotEmptyOrNumeric(selection As Range) As Boolean
IsSelectionNotEmptyOrNumeric = False
For Each cell In selection.Cells
If IsNumeric(cell.Value) Or cell.Value <> "" Then
IsSelectionNotEmptyOrNumeric = True
Exit For
End If
Next cell
End Function
Please, try the next adapted solution. It uses an array of formulas to be filled and its result is dropped at once, at the end of the code. It calculates an equivalent of your original (complicated) formulas, which needed a lot of Excel resources. I skipped the part which protect/unprotect the sheet and working on suppositions, it probably could be improved. But is should be faster. I also skipped the part which used to format the processed/added range. It can be easily done at once for a reasonable number of rows:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastR As Long: lastR = Me.Range("B" & Me.Rows.Count).End(xlUp).row
Dim rngBB As Range: Set rngBB = Me.Range("B15:B" & lastR)
If Not Intersect(Target, rngBB) Is Nothing Then
If Not Application.CutCopyMode And IsSelectionNotEmptyOrNumeric(Target) Then ' Check if cell contains a numeric value or is not empty and the change was made by the user
Dim arr, i As Long, rngDel As Range
If Target.Rows.Count > 1 Then
arr = Me.Range("A" & Target.row, "T" & Target.row + Target.Rows.Count - 1).Formula
arr = fillArray(arr, Intersect(Target, rngBB), rngDel)
Application.EnableEvents = False
Target.Offset(0, -1).Resize(UBound(arr), UBound(arr, 2)).Formula = arr 'drop the processed array content, at once
'delete the empty rows, if the case:
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
Application.EnableEvents = True
Else
Application.EnableEvents = False
If Intersect(Target, rngBB).Value = "" Then 'delete the row if Target is empty
Target.EntireRow.Delete
Application.EnableEvents = True
Exit Sub
End If
arr = Me.Range("A" & Target.row, "T" & Target.row).Formula
arr = fillArray(arr, Intersect(Target, rngBB), rngDel)
Target.Offset(0, -1).Resize(UBound(arr), UBound(arr, 2)).Formula = arr
Application.EnableEvents = True
End If
End If
End If
End Sub
Function fillArray(arr As Variant, Targ As Range, ByRef rngDel As Range) As Variant
Dim findC As Range, wsPrL As Worksheet, wsCustD As Worksheet, wsSt5104 As Worksheet, wsSt5102 As Worksheet
Dim mtch, strFormulaF As String, strFormulaI As String, i As Long
Set wsPrL = Me.Parent.Worksheets("PriceList")
Set wsCustD = Me.Parent.Worksheets("Customer_Database")
Set wsSt5104 = Me.Parent.Worksheets("StockList5104")
Set wsSt5102 = Me.Parent.Worksheets("StockList5102")
For i = 1 To UBound(arr)
'check if the target row is empty in its second column (to delete the row):_
If arr(i, 2) = "" Then
addToRange rngDel, Range("A" & Targ.row + i - 1)
GoTo SkipFilling
End If
'________________________________________________________________________
'solve D:D, K:K, G:G, S:S data from PriceList sheet_________________________________________________________________________
Set findC = wsPrL.Range("A:A").Find(what:=CStr(arr(i, 2)), LookIn:=xlValues, LookAt:=xlWhole) 'Find in "PriceList"
If Not findC Is Nothing Then
arr(i, 4) = "=" & findC.Offset(, 2).Address(0, 0, , True) 'place Description in D:D
arr(i, 11) = "=" & findC.Offset(, 4).Address(0, 0, , True) 'place Cost in K:K
arr(i, 19) = "=" & findC.Offset(, 6).Address(0, 0, , True) 'place Remarks in S:S
arr(i, 20) = "=" & findC.Offset(, 7).Address(0, 0, , True) 'place Tag in T:T
mtch = Application.Match(wsCustD.Range("B3").Value, wsPrL.Range("I3:N3").Value, 0) ' match the appropriate "P" type
If Not IsError(mtch) Then arr(i, 7) = "=" & wsPrL.Cells(findC.row, mtch + 8).Address(0, 0, , True) 'place the price in G:G
Else
arr(i, 4) = "Not found in ""PriceList""..."
arr(i, 1) = "=IF(" & Targ.Offset(i - 1).Address(0, 0) & "<>"""",ROW()-14)"
GoTo SkipFilling
End If
'__________________________________________________________________________________________________________________________
'Simple formulas on the same Quote_Master sheet_____________________________________________________________________
arr(i, 1) = "=IF(" & Targ.Offset(i - 1).Address(0, 0) & "<>"""",ROW()-14)" 'current number in A:A
arr(i, 8) = "=" & Targ.Offset(i - 1, 4).Address(0, 0) & "*" & Targ.Offset(i - 1, 5).Address(0, 0) 'in H:H (F * G)"
arr(i, 10) = "=" & Targ.Offset(i - 1, 4).Address(0, 0) & "*" & Targ.Offset(i - 1, 9).Address(0, 0) 'in H:H (F * K)"
arr(i, 12) = "=IFERROR(IF($AA$2=2," & Targ.Offset(i - 1, 5).Address(0, 0) & "/" & Targ.Offset(i - 1, 9).Address(0, 0) & _
"-1,(" & Targ.Offset(i - 1, 5).Address(0, 0) & "/" & Targ.Offset(i - 1, 9).Address(0, 0) & "-1)-5%),0)" 'In L:L
arr(i, 14) = "=IFERROR(IF($AA$2=2," & Targ.Offset(i - 1, 11).Address(0, 0) & "/" & Targ.Offset(i - 1, 9).Address(0, 0) & _
"-1,(" & Targ.Offset(i - 1, 11).Address(0, 0) & "/" & Targ.Offset(i - 1, 9).Address(0, 0) & "-1)-5%),0)" 'in N:N
arr(i, 15) = "=IFERROR(" & Targ.Offset(i - 1, 11).Address(0, 0) & "*" & Targ.Offset(i - 1, 4).Address(0, 0) & ",0)" 'in O:O
arr(i, 17) = "=IFERROR(IF($AA$2=2," & Targ.Offset(i - 1, 14).Address(0, 0) & "/" & Targ.Offset(i - 1, 9).Address(0, 0) & _
"- 1,(" & Targ.Offset(i - 1, 14).Address(0, 0) & "/" & Targ.Offset(i - 1, 9).Address(0, 0) & "-1)-5%),0)" 'In Q:Q
arr(i, 18) = "=IFERROR(" & Targ.Offset(i - 1, 14).Address(0, 0) & "*" & Targ.Offset(i - 1, 4).Address(0, 0) & ",0)" 'in R:R
'________________________________________________________________________________________________________________________
'Solve F:F and I:I________________________________________________________________________________________________________
Set findC = wsSt5104.Range("A:A").Find(what:=CStr(arr(i, 2)), LookIn:=xlValues, LookAt:=xlWhole) 'Find in "StockList5104"
If Not findC Is Nothing Then
strFormulaF = "=If($AA$1=2,IF(" & findC.Offset(, 2).Address(0, 0, , True) & ">0," & _
findC.Offset(, 2).Address(0, 0, , True) & ",E" & Targ.row + i - 1 & "),IF(" 'extract stock from "StockList5104"
strFormulaI = "=If($AA$1=2," & findC.Offset(, 2).Address(0, 0, , True) & ","
Else
strFormulaF = "=If($AA$1=2,IF(0>0,0,E" & Targ.row + i - 1 & "),IF("
strFormulaI = "=If($AA$1=2,0,"
End If
Set findC = wsSt5102.Range("A:A").Find(what:=CStr(arr(i, 2)), LookIn:=xlValues, LookAt:=xlWhole) 'Find in "StockList5102"
If Not findC Is Nothing Then
strFormulaF = strFormulaF & findC.Offset(, 2).Address(0, 0, , True) & ">0," & _
findC.Offset(, 2).Address(0, 0, , True) & ",E" & Targ.row + i - 1 & "))" 'extract stock from "StockList5102"
strFormulaI = strFormulaI & findC.Offset(, 2).Address(0, 0, , True) & ")"
Else
strFormulaF = strFormulaF & "0>0,0,E" & Targ.row + i - 1 & "))"
strFormulaI = strFormulaI & "0)"
End If
arr(i, 6) = strFormulaF ' simplified formula for stock inf F:F
arr(i, 9) = strFormulaI ' simplified formula for stock inf I:I
'_______________________________________________________________________________________________________________________
SkipFilling:
Next i
fillArray = arr 'return the processed array
End Function
Sub addToRange(rngU As Range, rng As Range)
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub
Please, send some feedback after testing it.
Edited:
In order to avoid formatting for each sheet change event, the next Sub should be run from time to time. The number of rows to be formatted is kept in the sheet "A5" cell (with white font color). For 10000 rows (just for testing) it takes about two, to three seconds:
Sub formatQuote_Master()
Dim wsQM As Worksheet, rngForm As Range, lastFRow As Long, arrBord, El
arrBord = Application.Evaluate("Row(7:12)") 'used to place cells borders
Set wsQM = ThisWorkbook.Worksheets("Quote_Master")
lastFRow = wsQM.Range("A5") 'with white font in A5 (1000 to test it)
Set rngForm = wsQM.Range("A15", "T" & lastFRow)
With rngForm
.Columns(1).HorizontalAlignment = xlCenter '"A:A"
Union(.Columns(2), .Columns(3), .Columns(4)).HorizontalAlignment = xlLeft '"B:D"
.Columns(2).NumberFormat = "@" 'some Part Number codes start with leading zero
With Union(.Columns(5), .Columns(6), .Columns(9)) '"E:F, I:I"
.HorizontalAlignment = xlCenter
.NumberFormat = "0"
End With
.Columns(13).Interior.Color = RGB(146, 2089, 80) '"M:M"
With Union(.Columns(7), .Columns(8), .Columns(10), .Columns(11), _
.Columns(13), .Columns(15), .Columns(16), .Columns(18)) '"G:G, H:H, J:J, K:K, M:M, O:O, P:P, R:R"
.NumberFormat = "0.00_-;[Red]-0.00_-;""-""??_-;@"
.HorizontalAlignment = xlRight
End With
With Union(.Columns(12), .Columns(14), .Columns(17)) '"L:L, N:N, Q:Q"
.HorizontalAlignment = xlRight
.NumberFormat = "0.00%"
End With
For Each El In arrBord 'place borders on the range cells:
With .Borders(El)
.LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = 0
End With
Next El
End With
MsgBox "Ready..."
End Sub
The code can be easily adapted to use two such cells and format starting from the already formatted row adding a specific constant number (took from another cell). As it is, it is faster than the way you are trying formatting in your code. It can be adapted to receive parameters and even being called from the event. If you do not like having the whole estimated range previously formatted...
The format above the 15th row should be done manually, because it needs to be done only once.