VBA Worksheet Change, loops and crashes Excel. How to work around?

Weeble

Board Regular
Joined
Nov 30, 2016
Messages
95
Office Version
  1. 365
So I am trying to paste information into a sheet.
When information is pasted i want this code to run.

Code:
Private Sub Worksheet_Change(ByVal Target As Range)Dim emptyRow As Long


'Sätt fliken lager som aktiv
Worksheets("Uppföljning").Activate


'Determine emptyRow
emptyRow = WorksheetFunction.CountA(Range("C:C")) + 1


On Error Resume Next
Cells(emptyRow, 6).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A1").Value
Cells(emptyRow, 11).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A2").Value
'Cells(emptyRow, 11).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A3").Value
'Cells(emptyRow, 11).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A4").Value
Cells(emptyRow, 5).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A5").Value
Cells(emptyRow, 8).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A6").Value
Cells(emptyRow, 7).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A7").Value
'Cells(emptyRow, 11).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A8").Value
Cells(emptyRow, 3).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A14").Value
Cells(emptyRow, 4).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A15").Value




ThisWorkbook.Worksheets("Mailklipp").Range("A1:A15").Clear
ThisWorkbook.Worksheets("Mailklipp").Range("A1").Value = "Klipp in här"
ThisWorkbook.Worksheets("Mailklipp").Range("A1").Interior.Color = RGB(67, 152, 61)


End Sub

But since they code is actualy changing in the workbook aswell, my guess is that it crashes it.
Is there any way to get around this?
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
You need to turn of events at the start of your sub usng this code:
Code:
A[COLOR=#171717][FONT=SFMono-Regular]pplication.EnableEvents = [/FONT][/COLOR][COLOR=#07704A][FONT=SFMono-Regular]False[/FONT][/COLOR]
then at the end ofthe code you need to turn them on again with this code:
Code:
[COLOR=#171717][FONT=SFMono-Regular]Application.EnableEvents = [/FONT][/COLOR][FONT=SFMono-Regular][COLOR=#07704a]True[/COLOR][/FONT]
what is happening is that when you write to cells(emptyrow,6) ( and all the subsequent lines) , it triggers the worksheet change event again even though you are in the middle of it, so you get an endless loop
 
Last edited:
Upvote 0
Tried this, but what happens is that it writes the pasted lines in sheet("mailklipp").
Looks like the EnableEvents terminates the
Code:
[COLOR=#333333]Worksheets("Uppföljning").Activate[/COLOR]
function.
I tried changing my code to this
Code:
Private Sub Worksheet_Change(ByVal Target As Range)Dim emptyRow As Long


Application.EnableEvents = False


'Sätt fliken lager som aktiv
Worksheets("Uppföljning").Activate


'Determine emptyRow
emptyRow = WorksheetFunction.CountA(Range("C:C")) + 1


On Error Resume Next
ThisWorkbook.Worksheets("Uppföljning").Cells(emptyRow, 6).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A1").Value
ThisWorkbook.Worksheets("Uppföljning").Cells(emptyRow, 11).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A2").Value
'Cells(emptyRow, 11).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A3").Value
'Cells(emptyRow, 11).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A4").Value
ThisWorkbook.Worksheets("Uppföljning").Cells(emptyRow, 5).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A5").Value
ThisWorkbook.Worksheets("Uppföljning").Cells(emptyRow, 8).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A6").Value
ThisWorkbook.Worksheets("Uppföljning").Cells(emptyRow, 7).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A7").Value
'Cells(emptyRow, 11).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A8").Value
ThisWorkbook.Worksheets("Uppföljning").Cells(emptyRow, 3).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A14").Value
ThisWorkbook.Worksheets("Uppföljning").Cells(emptyRow, 4).Value = ThisWorkbook.Worksheets("Mailklipp").Range("A15").Value




ThisWorkbook.Worksheets("Mailklipp").Range("A1:A15").Clear
ThisWorkbook.Worksheets("Mailklipp").Range("A1").Value = "Klipp in här"
ThisWorkbook.Worksheets("Mailklipp").Range("A1").Interior.Color = RGB(67, 152, 61)
Application.EnableEvents = True
End Sub

I now get the pasted values in the right Worksheet, but it does not run my
Code:
[COLOR=#333333]emptyRow = WorksheetFunction.CountA(Range("C:C")) + 1[/COLOR]
It paste eveything on First row.
 
Upvote 0
Which sheet is that code in?
 
Upvote 0
In that case try
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim emptyRow As Long


'Sätt fliken lager som aktiv
With Worksheets("Uppföljning")
   
   
   'Determine emptyRow
   emptyRow = WorksheetFunction.CountA(.Range("C:C")) + 1
   
   
   .Cells(emptyRow, 6).Value = Me.Range("A1").Value
   .Cells(emptyRow, 11).Value = Me.Range("A2").Value
   '.Cells(emptyRow, 11).Value = me.Range("A3").Value
   '.Cells(emptyRow, 11).Value = me.Range("A4").Value
   .Cells(emptyRow, 5).Value = Me.Range("A5").Value
   .Cells(emptyRow, 8).Value = Me.Range("A6").Value
   .Cells(emptyRow, 7).Value = Me.Range("A7").Value
   '.Cells(emptyRow, 11).Value = me.Range("A8").Value
   .Cells(emptyRow, 3).Value = Me.Range("A14").Value
   .Cells(emptyRow, 4).Value = Me.Range("A15").Value
End With


Application.EnableEvents = False
Me.Range("A1:A15").Clear
Me.Range("A1").Value = "Klipp in här"
Me.Range("A1").Interior.Color = RGB(67, 152, 61)
Application.EnableEvents = True

End Sub
 
Upvote 0
You're welcome & thanks for the feedback.

In this context Me is the sheet that contains the code.
 
Upvote 0

Forum statistics

Threads
1,223,894
Messages
6,175,252
Members
452,623
Latest member
Techenthusiast

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top