Looping a worksheet change event

[dan_schofield]

Hello all

Im ok at writing some simple code in vba but when it comes to looping the code I always screw it up!

I have a code that is working and doing what I want it to do, except I have to re write this for 10000 cells! which is extremely time consuming, as you will see I have shown the exact code for a change event on cell O479 and O480. But I want to make it run from O20 through to O10000

How do I loop this? as in what is the correct procedure for Dim? Loop? Next Event? im not sure what to do

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("o480")) Is Nothing Then
  If Worksheets("Purchase Orders").Range("o480").Value = "Yes" Then
     Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
  .To = "[EMAIL="Maintenance@newcenturycare.co.uk"]Maintenance@newcenturycare.co.uk[/EMAIL]; [EMAIL="Modrek.Zandy@newcenturycare.co.uk"]Modrek.Zandy@newcenturycare.co.uk[/EMAIL]; [EMAIL="Purchase.ledger@newcenturycare.co.uk"]Purchase.ledger@newcenturycare.co.uk[/EMAIL]"
  .CC = Worksheets("Purchase Orders").Range("z480").Value
  .Subject = "PO/Capex Request Approval"
  .Body = "Hello," & vbCrLf & vbCrLf & "I have approved the following PO/Capex requests" & vbCrLf & vbCrLf & Worksheets("Purchase Orders").Range("C180").Value & vbCrLf & vbCrLf & "Regards" & vbCrLf & vbCrLf & Worksheets("Purchase Orders").Range("Q480").Value
  .Display
End With
End If
End If
 If Not Intersect(Target, Range("o479")) Is Nothing Then
   If Worksheets("Purchase Orders").Range("o479").Value = "Yes" Then
     Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
  .To = "[EMAIL="Maintenance@newcenturycare.co.uk"]Maintenance@newcenturycare.co.uk[/EMAIL]; [EMAIL="Modrek.Zandy@newcenturycare.co.uk"]Modrek.Zandy@newcenturycare.co.uk[/EMAIL]; [EMAIL="Purchase.ledger@newcenturycare.co.uk"]Purchase.ledger@newcenturycare.co.uk[/EMAIL]"
  .CC = Worksheets("Purchase Orders").Range("z479").Value
  .Subject = "PO/Capex Request Approval"
  .Body = "Hello," & vbCrLf & vbCrLf & "I have approved the following PO/Capex requests" & vbCrLf & vbCrLf & Worksheets("Purchase Orders").Range("C479").Value & vbCrLf & vbCrLf & "Regards" & vbCrLf & vbCrLf & Worksheets("Purchase Orders").Range("Q480").Value
  .Display
End With
End If
End If
End Sub

Any help or pointers would be great to help me understand how to create loops

Thanks

Dan

 

[Special-K99]

Does this work (untested and am no VBA expert) ?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel as range

For Each cel in Range("O20:O10000")
  If Not Intersect(Target, cel) Is Nothing Then
  If Worksheets("Purchase Orders").cel.Value = "Yes" Then
     Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
  .To = "Maintenance@newcenturycare.co.uk; Modrek.Zandy@newcenturycare.co.uk; Purchase.ledger@newcenturycare.co.uk"
  .CC = Worksheets("Purchase Orders").cel.offset(0,11).Value
  .Subject = "PO/Capex Request Approval"
  .Body = "Hello," & vbCrLf & vbCrLf & "I have approved the following PO/Capex requests" & vbCrLf & vbCrLf & Worksheets("Purchase Orders").cel.offset(0,-12).Value & vbCrLf & vbCrLf & "Regards" & vbCrLf & vbCrLf & Worksheets("Purchase Orders").cel.offset(0,2).Value
  .Display
End With
End If
End If
Next cel
End Sub

As this is untested I would change the email To address so you dont suddenly start emailing those people thousands of incorrect emails

 

[offthelip]

@Special K looping thorugh 10000 cells checking each one everytime there is a worksheet_chagne event is guaranteed to really slow down the workbook .
I have posted the following paragraph many many times on this forum and other forums:
One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.
So instead of writing a loop which loops down a range checking one row at a time which will take along time if you have got 10000 rows it is much quicker to load the 10000 lines into a variant array ( one worksheet access), then check the lines in the variant array ,
I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.
I have rewritten your code to use a variant array, and you can see it is very similar but it will be about 800 times faster at least.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Variant


 If Not Intersect(Target, Range("O20:O10000")) Is Nothing Then
  cel = Range("O1:O10000")
  For i = 20 To 10000
    If cel(i, 1) = "Yes" Then
        Set xOutlookObj = CreateObject("Outlook.Application")
       Set xEmailObj = xOutlookObj.CreateItem(0)
       With xEmailObj
      .To = "Maintenance@newcenturycare.co.uk; Modrek.Zandy@newcenturycare.co.uk; Purchase.ledger@newcenturycare.co.uk"
      .CC = Worksheets("Purchase Orders").Cells(i, 26).Value
      .Subject = "PO/Capex Request Approval"
      .Body = "Hello," & vbCrLf & vbCrLf & "I have approved the following PO/Capex requests" & vbCrLf & vbCrLf & Worksheets("Purchase Orders").cel.Offset(0, -12).Value & vbCrLf & vbCrLf & "Regards" & vbCrLf & vbCrLf & Worksheets("Purchase Orders").cel.Offset(0, 2).Value
      .Display
    End If
  Next i
 
End If
End Sub

Note I haven't tested this either so there may well be errors in it.

 

[dan_schofield]

Thank you both I put both codes in to my sheet to try and had to made a small adjustment,

Doing so it created an email for every cell in column O that says "yes" but I assumed the intersect code would only pick up when the cell has been changed (change event)

I put an "end with" and then next I hoping that stops it but it doesn't

The other error I get is on the offset code, so I changed it to Cells(i, 3).Value and that works.... but.... it created hundreds of emails

How does this code work only on the changing of a dropdown, rather than looking at every cell

ideally I need to do
if dropdown is "changed" to yes then email, otherwise do nothing

Thanks

Dan

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Variant

 If Not Intersect(Target, Range("O20:O10000")) Is Nothing Then
  cel = Range("O1:O10000")
  For i = 20 To 10000
    If cel(i, 1) = "Yes" Then
        Set xOutlookObj = CreateObject("Outlook.Application")
       Set xEmailObj = xOutlookObj.CreateItem(0)
       With xEmailObj
      .To = "[EMAIL="Maintenance@newcenturycare.co.uk"]Maintenance@newcenturycare.co.uk[/EMAIL]; [EMAIL="Modrek.Zandy@newcenturycare.co.uk"]Modrek.Zandy@newcenturycare.co.uk[/EMAIL]; [EMAIL="Purchase.ledger@newcenturycare.co.uk"]Purchase.ledger@newcenturycare.co.uk[/EMAIL]"
      .CC = Worksheets("Purchase Orders").Cells(i, 26).Value
      .Subject = "PO/Capex Request Approval"
      .Body = "Hello," & vbCrLf & vbCrLf & "I have approved the following PO/Capex requests" & vbCrLf & vbCrLf & Worksheets("Purchase Orders").Cells(i, 3).Value & vbCrLf & vbCrLf & "Regards" & vbCrLf & vbCrLf & Worksheets("Purchase Orders").Cells(i, 17).Value
      .Display
      End With
      End If
    Next i
    End If
End Sub

 

[offthelip]

The answer is to use the target range which is only the cells or cells that have changed. Assuming that only one cell has changed you can forget the loop, so delete the code for i = 20 to 10000
You can find the row that has changed by using the code to find the row and then change the if statement:

rowno=target.row

if cells(rowno,15)="Yes"

If you are expecting more that one cells to have changed in one worksheet change event, then you need to test whether "target" is a range which is larger than one cell and then iterate through all the cells in target. Which you can do using a similr loop to your existing loop

 

[dan_schofield]

Hi @offthelip

Yes I only want it to work when the cell is changed, so would be looking at one cell at a time throughout the range, I will give that a go, and remove the Next I fingers crossed that works

Thank you

 

[offthelip]

I have just noticed that you will also have to change this line:

[COLOR=#333333].CC = Worksheets("Purchase Orders").Cells(i, 26).Value[/COLOR]

to

[COLOR=#333333].CC = Worksheets("Purchase Orders").Cells(rowno, 26).Value[/COLOR]

 

[dan_schofield]

Hi @offthelip

I tried the change for the target range and that worked perfectly I did have to change the CC line, it come up with a debug error, and noticed I was no longer

Thank you for your help and for explanation around the coding