Need help with code re-written

[Hyakkivn]

I
Private Sub Worksheet_Change(ByVal Target As Range)
Application.screenupdating = FALSE
Dim i As Long, cell As Range
Dim lastRow As Long, count As Long
Dim tdc As Variant, nth As Variant
tdc = Array("C", "D", "E", "F", "H", "I", "J")
nth = Array("I", "J", "K")
Dim bc As Worksheet, d As Worksheet, r As Worksheet
Set bc = Worksheets("Baocao")
lastRow = Cells(Rows.count, "D").End(xlUp).Row

If Not Intersect(Target, Range("D" & lastRow)) Is Nothing Then
For Each cell In Intersect(Range("D2:D300"), Target).Cells
count = Application.WorksheetFunction.count(Range("C2:C300"))
bc.Range("O7").Value = count
If lastrow >= 2 Then
Dim sumValue As Double
sumValue = Application.WorksheetFunction.Sum(Range("G2:G300")) / 1000
bc.Range("P7").Value = sumValue
End If
Next cell
For Each cell In Intersect(Range("D2:D300"), Target).Cells
If cell.Value = "" Then
cell.Offset(, -3).Value = ""
cell.Offset(, 8).Value = ""
cell.Offset(, 9).Value = ""
cell.Offset(, 10).Value = ""
ElseIf cell.Value <> "" Then
cell.Offset(, -3).Value = Range("N1").Value
End If
Next cell
For i = 2 To lastRow
Range("L" & i).Formula = "=IFERROR(LEFT(D" & i & ", LEN(D" & i & ") - 5), """")"
Range("M" & i).Formula = "=IFERROR(RIGHT(D" & i & ", 4), """")"
Range("N" & i).Formula = "=iferror(left(D" & i & ", 3), """")"
Range("L" & i).Value = Range("L" & i).Value
Range("M" & i).Value = Range("M" & i).Value
Range("N" & i).Value = Range("N" & i).Value
Next i
For i = 24 To 30
For Each cl In tdc
bc.Range(cl & i).Value = WorksheetFunction.SumIfs(Range("G2:G300"), Range("L2:L300"), bc.Range("B" & i).Value, _
Range("M2:M300"), bc.Range(cl & "22").Value) / 1000
Next cl
Next i
For i = 14 To 18
For Each cl In nth
bc.Range(cl & i).Value = WorksheetFunction.SumIfs(Range("G2:G300"), Range("L2:L300"), bc.Range("H" & i).Value, _
Range("M2:M300"), bc.Range(cl & "13").Value) / 1000
Next cl
Next i
For Each cell In Range("B2:B" & Rows.count)
' Check if the cell value is "Toa"
If cell.Value = "Toa" Then
' Get the row number of the cell
row_num = cell.Row

' Loop through columns A to K for the row and delete the cell values
For col = 1 To 11
Cells(row_num, col).Value = ""
Next col
End If
Next cell
End If
End Sub

I made this code, and it works. But it is slow because of ranges and loops, I think. So, I need suggestion to re-write the code to be faster and more effective. Thanks in advance !!!

 

[Jeffrey Mahoney]

I encourage everybody I help to indent your code and give yourself some spaces in between sections of code. It is much more easier to read

See the comments within the code below

Private Sub Worksheet_Change(ByVal Target As Range)
  
  Dim i As Long, cell As Range
  Dim lastRow As Long, count As Long
  Dim tdc As Variant, nth As Variant
  Dim bc As Worksheet, d As Worksheet, r As Worksheet
  Dim sumValue As Double
  
  Dim u As Range          'Used to store all the cells needing to be cleared
  Set u = Range("zz1000000")                                    'Empty cell
  
  If Not Intersect(Target, Range("D" & lastRow)) Is Nothing Then Exit Sub
  
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Application.EnableEvents = False
  
  tdc = Array("C", "D", "E", "F", "H", "I", "J")
  nth = Array("I", "J", "K")
  Set bc = Worksheets("Baocao")
  lastRow = Cells(Rows.count, "D").End(xlUp).Row

  'moved these out of the For Each cell because it is the same result either way and not calculated 298 times
  count = Application.WorksheetFunction.count(Range("C2:C300"))           '<<<
  bc.Range("O7").Value = count                                            '<<<
  If lastRow >= 2 Then
    sumValue = Application.WorksheetFunction.Sum(Range("G2:G300")) / 1000   '<<<
    bc.Range("P7").Value = sumValue
  End If
  'There is no need for this for each cell
'  For Each cell In Intersect(Range("D2:D300"), Target).Cells
'
'  Next cell
  
  For Each cell In Intersect(Range("D2:D300"), Target).Cells
    If cell.Value = "" Then
      Set u = Union(u, cell.Offset(, -3), cell.Offset(, 8), cell.Offset(, 9), cell.Offset(, 10))
    ElseIf cell.Value <> "" Then
      cell.Offset(, -3).Value = Range("N1").Value
    End If
  Next cell
  
  'Got rid of the For loop.  I think this is faster for this section
  i = 2
  Range("L" & i).Formula = "=IFERROR(LEFT(D" & i & ", LEN(D" & i & ") - 5), """")"
  Range("M" & i).Formula = "=IFERROR(RIGHT(D" & i & ", 4), """")"
  Range("N" & i).Formula = "=IFERROR(left(D" & i & ", 3), """")"
    
  Range("L" & i).Copy Range("L" & i & ":" & "L" & lastRow)
  Range("M" & i).Copy Range("M" & i & ":" & "M" & lastRow)
  Range("N" & i).Copy Range("N" & i & ":" & "N" & lastRow)
  
  Range("L" & i & ":" & "L" & lastRow).Value = Range("L" & i & ":" & "L" & lastRow).Value
  Range("M" & i & ":" & "M" & lastRow).Value = Range("M" & i & ":" & "M" & lastRow).Value
  Range("N" & i & ":" & "N" & lastRow).Value = Range("N" & i & ":" & "N" & lastRow).Value
  
    
  
  For i = 24 To 30
    For Each cl In tdc
      bc.Range(cl & i).Value = WorksheetFunction.SumIfs(Range("G2:G300"), Range("L2:L300"), bc.Range("B" & i).Value, _
      Range("M2:M300"), bc.Range(cl & "22").Value) / 1000
    Next cl
  Next i
  
  For i = 14 To 18
    For Each cl In nth
      bc.Range(cl & i).Value = WorksheetFunction.SumIfs(Range("G2:G300"), Range("L2:L300"), bc.Range("H" & i).Value, _
      Range("M2:M300"), bc.Range(cl & "13").Value) / 1000
    Next cl
  Next i
  
  For Each cell In Range("B2:B" & Rows.count)
    ' Check if the cell value is "Toa"
    If cell.Value = "Toa" Then
      ' Get the row number of the cell
      row_num = cell.Row

      ' Loop through columns A to K for the row and delete the cell values
      For col = 1 To 11
        Set u = Union(u, Cells(row_num, col))
        'Cells(row_num, col).Value = ""
      Next col
    End If
  Next cell
  
  u.Value = ""                                  'Set all the cells to blank at once
  

  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  Application.EnableEvents = True


End Sub

 

[Jeffrey Mahoney]

OH, by the way, please test this code before running a live version. I don't have the ability to test it on anything

 

[MARK858]

I encourage everybody I help to indent your code and give yourself some spaces in between sections of code. It is much more easier to read

I think it shows like that because the OP has put the code in a quote rather than a VBA tag

 

[Hyakkivn]

OH, by the way, please test this code before running a live version. I don't have the ability to test it on anything

Thank you for your reply... But the code failed at some point. I will re-construct the code base on your suggest. Thanks a lot !

 

[Jeffrey Mahoney]

What line failed?