I have a macro associated with a workbook to trigger some events when data is entered in column B. Along with this, there are two other modules related to this to for uploading excel when so many data are there and one module to protect and unprotect the sheet. Macro works fine in all scenarios except uploading part, when i am uploading any excel to pull the data, the event is triggered only for the first line and the balance items are just being pasted without triggering the event. I tried the debugging the code by putting a line break and running the code line by line while uploading the excel, at that time its properly doing everything, but when i run it, it is only running for the 1st item.
Main macro
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
On Error Resume Next
Protect_Unprotect.UnProtectSheet
Range("A" & cell.row).Formula = "=IFERROR(IF(B" & cell.row & "<>"""",ROW()-ROW($A$15)+1,""""),0)"
Range("H" & cell.row).Formula = "=IFERROR(IF(B" & cell.row & "<>"""",G" & cell.row & "*F" & cell.row & ",""""),0)"
Range("D" & cell.row).Formula = "=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).Formula = "=IFERROR(IF($AA1=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).Formula = "=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("J" & cell.row).Formula = "=IFERROR(INDEX(PriceList!$E$4:$E$7956,MATCH(B" & cell.row & ",PriceList!$A$4:$A$7956,0)),0)"
Range("L" & cell.row).Formula = "=IFERROR(IF(B" & cell.row & "<>"""",G" & cell.row & "/J" & cell.row & "-1,""""),0)"
Range("N" & cell.row).Formula = "=IFERROR(IF(B" & cell.row & "<>"""",M" & cell.row & "/J" & cell.row & "-1,""""),0)"
Range("O" & cell.row).Formula = "=IFERROR(IF(B" & cell.row & "<>"""",M" & cell.row & "*F" & cell.row & ",""""),0)"
Range("K" & cell.row).Formula = "=IFERROR(IF(B" & cell.row & "<>"""",J" & cell.row & "*F" & cell.row & ",""""),0)"
' 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
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 & ":S" & 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
Else
' Add row to deleteRows range
If deleteRows Is Nothing Then
Set deleteRows = Rows(cell.row)
Else
Set deleteRows = Union(deleteRows, Rows(cell.row))
End If
End If
Next cell
On Error Resume Next
Protect_Unprotect.ProtectSheet
'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
'Calculations for the header cells
lastrow = Cells(Rows.Count, "B").End(xlUp).row
Range("H6").Formula = "=TODAY()"
Range("H9").Formula = "=IFERROR(SUM(E15:E" & lastrow & "),"""")"
Range("H8").Value = Application.WorksheetFunction.CountA(Range("B15:B" & Cells(Rows.Count, "B").End(xlUp).row))
Range("H10").Formula = "=IFERROR(SUM(F15:F" & Cells(Rows.Count, "F").End(xlUp).row & "),"""")"
Range("H11").Formula = "=IFERROR(ROUND(SUM(H15:H" & Cells(Rows.Count, "H").End(xlUp).row & "),2),"""")"
Range("M6").Formula = "=IFERROR(ROUND(SUM(K15:K" & Cells(Rows.Count, "K").End(xlUp).row & "),2),"""")"
Range("M7").Formula = "=IFERROR(H11/M6-1,"""")"
Range("M8").Formula = "=IFERROR(ROUND(SUM(O15:O" & Cells(Rows.Count, "O").End(xlUp).row & "),2),"""")"
Range("M9").Formula = "=IFERROR(ROUND(M8/M6-1,2),"""")"
Range("M10").Formula = "=IFERROR(ROUND(SUM(R15:R" & Cells(Rows.Count, "R").End(xlUp).row & "),2),"""")"
Range("M11").Formula = "=IFERROR(ROUND(M10/M6-1,2),"""")"
' Delete entire rows in deleteRows range
If Not deleteRows Is Nothing Then
On Error Resume Next
Protect_Unprotect.UnProtectSheet
Application.EnableEvents = False ' Disable events to avoid triggering the event again
deleteRows.Delete
Application.EnableEvents = True ' Enable events again
End If
Else
If Target.Value <> "" Then
On Error Resume Next
Protect_Unprotect.UnProtectSheet
Range("A" & Target.row).Formula = "=IFERROR(IF(B" & Target.row & "<>"""",ROW()-ROW($A$15)+1,""""),0)"
Range("H" & Target.row).Formula = "=IFERROR(IF(B" & Target.row & "<>"""",G" & Target.row & "*F" & Target.row & ",""""),0)"
Range("D" & Target.row).Formula = "=IFERROR(INDEX(PriceList!$C$4:$C$7956,MATCH(B" & Target.row & ",PriceList!$A$4:$A$7956,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("F" & Target.row).Formula = "=IFERROR(IF($AA1=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("I" & Target.row).Formula = "=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).Formula = "=IFERROR(INDEX(PriceList!$E$4:$E$7956,MATCH(B" & Target.row & ",PriceList!$A$4:$A$7956,0)),0)"
Range("L" & Target.row).Formula = "=IFERROR(IF(B" & Target.row & "<>"""",G" & Target.row & "/J" & Target.row & "-1,""""),0)"
Range("N" & Target.row).Formula = "=IFERROR(IF(B" & Target.row & "<>"""",M" & Target.row & "/J" & Target.row & "-1,""""),0)"
Range("O" & Target.row).Formula = "=IFERROR(IF(B" & Target.row & "<>"""",M" & Target.row & "*F" & Target.row & ",""""),0)"
Range("K" & Target.row).Formula = "=IFERROR(IF(B" & Target.row & "<>"""",J" & Target.row & "*F" & Target.row & ",""""),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
Dim rnge1 As Range
Set rnge1 = Union(Range("E" & Target.row), Range("F" & Target.row), Range("I" & Target.row))
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))
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))
With rnge3
.HorizontalAlignment = xlRight
.NumberFormat = "0.00%"
End With
' Copy border, border color and orientation from row above
With Range("A" & Target.row & ":S" & 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
On Error Resume Next
Protect_Unprotect.ProtectSheet
lastrow = Cells(Rows.Count, "B").End(xlUp).row
Range("H6").Formula = "=TODAY()"
Range("H9").Formula = "=IFERROR(SUM(E15:E" & lastrow & "),"""")"
Range("H8").Value = Application.WorksheetFunction.CountA(Range("B15:B" & Cells(Rows.Count, "B").End(xlUp).row))
Range("H10").Formula = "=IFERROR(SUM(F15:F" & Cells(Rows.Count, "F").End(xlUp).row & "),"""")"
Range("H11").Formula = "=IFERROR(ROUND(SUM(H15:H" & Cells(Rows.Count, "H").End(xlUp).row & "),2),"""")"
Range("M6").Formula = "=IFERROR(ROUND(SUM(K15:K" & Cells(Rows.Count, "K").End(xlUp).row & "),2),"""")"
Range("M7").Formula = "=IFERROR(H11/M6-1,"""")"
Range("M8").Formula = "=IFERROR(ROUND(SUM(O15:O" & Cells(Rows.Count, "O").End(xlUp).row & "),2),"""")"
Range("M9").Formula = "=IFERROR(ROUND(M8/M6-1,2),"""")"
Range("M10").Formula = "=IFERROR(ROUND(SUM(R15:R" & Cells(Rows.Count, "R").End(xlUp).row & "),2),"""")"
Range("M11").Formula = "=IFERROR(ROUND(M10/M6-1,2),"""")"
Else
' Delete entire row
On Error Resume Next
Protect_Unprotect.UnProtectSheet
Application.EnableEvents = False ' Disable events to avoid triggering the event again
Rows(Target.row).Delete
Application.EnableEvents = True ' Enable events again
End If
End If
End If
End If
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
This is the second: Macro for excel uploading
Option Explicit
Private Sub Upload_Excel()
On Error Resume Next
Protect_Unprotect.UnProtectSheet
On Error GoTo ErrorHandler
Dim wb As Workbook
Dim ws As Worksheet
Dim rngA As Range, rngB As Range
Dim i As Long, n As Long
Application.Visible = False
'Open the dialog box to select a file
Set wb = Application.Workbooks.Open(Application.GetOpenFilename(), False, True)
Application.ScreenUpdating = False
'Set the worksheet to import data from
Set ws = wb.Worksheets(1)
'Count the number of rows to import
n = ws.Range("A:A").SpecialCells(xlCellTypeConstants).Count
Application.ScreenUpdating = True
Application.Visible = True
'Show the progress bar userform
UserForm1.Show vbModeless
'Copy the data from column A and B of the selected worksheet
Set rngA = ws.Range("A:A").SpecialCells(xlCellTypeConstants)
Set rngB = ws.Range("B:B").SpecialCells(xlCellTypeConstants)
'Paste the data to Quote_Master worksheet starting from cell A15 and E15
With ThisWorkbook.Worksheets("Quote_Master")
For i = 1 To n
.Range("B15").Offset(i - 1).Value = rngA.Cells(i).Value
.Range("E15").Offset(i - 1).Value = rngB.Cells(i).Value
'Update the progress bar
UserForm1.ProgressBar1.Value = i / n * 100
DoEvents
Next i
End With
'Close the workbook without saving changes
wb.Close SaveChanges:=False
On Error Resume Next
'Hide the progress bar userform
UserForm1.Hide
Unload UserForm1
On Error GoTo 0
Protect_Unprotect.ProtectSheet
Exit Sub
ErrorHandler:
Application.Visible = True
MsgBox "The Upload was cancelled." 'Display message if the user cancels or closes the dialog box
End Sub
Macro for protect & unprotect the sheet
Sub ProtectSheet()
Dim wb As Workbook
Dim ws As Worksheet
Dim rnge As Range
Dim rnge2 As Range
Set wb = Workbooks("Quote Master.xlsm")
Set ws = wb.Sheets("Quote_Master")
Set rnge2 = ws.Range("B15:B1000", "E15:E1000")
Set rnge = Union(ws.Range("A15:A1000"), ws.Range("C15:D1000"), ws.Range("F15:G1000"))
With rnge2
On Error Resume Next
.Locked = False
.FormulaHidden = False
End With
With rnge
.Locked = True
.FormulaHidden = True
End With
ws.Protect "123", True, True
End Sub
Sub UnProtectSheet()
ActiveSheet.Unprotect "123"
End Sub
