Hi Gordom,
Although I am not entirely sure whats going on here, I broke down some of
the Worksheet_Calculate procedure into smaller self explanatory procedures.
There seemed to be some superfluous code i.e. your arrays and for next loops
that didnt seem to do anything. Give the below a try to see if it suits
your needs. HTH
'**********Start code *************
Option Explicit

Private Sub Worksheet_Calculate()
Dim S As Single

' If These two ranges match do Nothing?
If Range("A9").Value < Range("A6").Value Then

S = Timer + 3 'Not sure what's going on here, doing nothing?
Do While Timer < S '
DoEvents '
Loop

'if the previous two ranges don't match,
'make them match? Why not just have the following line?
Range("A6").Value = Range("A9")


Application.ScreenUpdating = False

' Mark "0" Prices in red
Call MarkZeroPrices("Sheet2")

' Mar tranlated products in yellow
Call MarkTranslatedProducts("Sheet2")


Application.ScreenUpdating = True
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$244" Then
ActiveSheet.PivotTables("Tabela przestawna2").PivotCache.Refresh
End If
End Sub

'________________________________________________
'
'FIND "0" PRICES PRODUCTS AND MARK THEM BY COLOR
'________________________________________________
Public Sub MarkZeroPrices(ByVal Name As String)
Dim Ws As Worksheet
Dim aRange As Range
Dim aFoundCell As Range
Dim FirstAddress As Variant
Set Ws = Worksheets(Name)
Set aRange = Ws.Range("N:N")


With aRange
' Look for cells that contain "0"(Zero) as a value.
Set aFoundCell = .Find(what:="0", After:=.Cells(.Cells.Count),
LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)


If Not aFoundCell Is Nothing Then
FirstAddress = aFoundCell.Address ' Found a Cell containg value "0"
Do
aFoundCell.Interior.ColorIndex = 3 ' Color it red
Set aFoundCell = .FindNext(aFoundCell)
Loop Until aFoundCell Is Nothing Or FirstAddress = aFoundCell.Address
End If
End With

If vbNo < MsgBox("0 prices products are red. Do you want white color
back?", _
vbQuestion + vbYesNo, "0 prices products") Then
ResetInteriorColor Ws.Name, 3
End If
End Sub

'________________________________________________
'
'FIND TRANSLATED PRODUCTS AND MARK THEM BY COLOR
'________________________________________________
Public Sub MarkTranslatedProducts(ByVal Name As String)
Dim Ws As Worksheet
Dim aRange As Range
Dim aFoundCell As Range
Dim FirstAddress As Variant
Set Ws = Worksheets(Name)
Set aRange = Ws.Range("O:O")


With aRange
' Look for cells that contain text "EN"
Set aFoundCell = .Find(what:="EN", After:=.Cells(.Cells.Count),
LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)

If Not aFoundCell Is Nothing Then
FirstAddress = aFoundCell.Address ' Found one
Do
aFoundCell.Interior.ColorIndex = 6 ' Turn it yellow
Set aFoundCell = .FindNext(aFoundCell)
Loop Until aFoundCell Is Nothing Or FirstAddress = aFoundCell.Address
End If
End With

If vbNo < MsgBox("Translated products are yellow. Do you want white
color back?", _
vbQuestion + vbYesNo, "") Then
ResetInteriorColor Ws.Name, 6
End If

End Sub

'_____________________________________________
'
'RESET CELLS BACKCOLOR TO NOTHING
'_____________________________________________
Public Sub ResetInteriorColor(ByVal Name As String, ByVal Color As Integer)

Dim aCell As Range
Dim aRange As Range
Dim Ws As Worksheet

Set Ws = Worksheets(Name)
Set aRange = Ws.UsedRange

For Each aCell In aRange
If aCell.Interior.ColorIndex = Color Then
aCell.Interior.ColorIndex = xlNone
End If
Next
End Sub

'*******End Code**********
"gordom" wrote:

Hello everyone.
I'm rather VB illiterate. Usually I compile fragments of code found
somewhere on the internet and try to adopt them to my needs. I did
something like that this time also. Unfortunately there is some problem.
Because I haven't been able to resolve it on my own (in spite of many
tries), I would like to ask you for a help.
Basically I implemented a new piece of code into a macro which was used
for a long time. Both pieces of the code (a new and the old one) work
fine if they are separated. If I combine them into one SUB it's also OK,
on one condition however - the macro must be triggered by pressing a
button. The problem occurs if I want to implement the new code into
Private Sub Worksheet_Calculate(). In that case Excel hangs while new
macro is executed. I think that a new piece of code corrupts something
but I don't know what.
I'm sending the fragment with a new code. It's a pretty much a long one,
I know. Sorry for that. I hope however that somebody could look through
and point the problem. I would appreciate your help very much. Thanks in
advance.

gordom


The code:





Private Sub Worksheet_Calculate()

If Range("A9").Value < Range("A6").Value Then

s = Timer + 3
Do While Timer < s
DoEvents
Loop

Range("A6").Value = Range("A9")

Application.ScreenUpdating = False

Dim FirstAddress1 As String
Dim MySearch1 As Variant
Dim myColor1 As Variant
Dim Rng1 As Range
Dim I1 As Long
Dim Answer1 As String
Dim MyNote1 As String


Dim FirstAddress As String
Dim MySearch As Variant
Dim myColor As Variant
Dim Rng As Range
Dim I As Long
Dim Answer As String
Dim MyNote As String

Dim c As Range
'______________________________________________
'FIND 0 PRICES PRODUCTS AND MARK THEM BY COLOR

MySearch1 = Array("0")
myColor1 = Array("3")

With Sheets("cennik_SET").Range("N:N")

For I1 = LBound(MySearch1) To UBound(MySearch1)

Set Rng1 = .Find(what:=MySearch1(I1), _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

If Not Rng1 Is Nothing Then
FirstAddress1 = Rng1.Address
Do
Rng1.Interior.ColorIndex = myColor1(I1)
Set Rng1 = .FindNext(Rng1)
Loop While Not Rng1 Is Nothing And Rng1.Address < FirstAddress1

'_______
'MESSAGE

MyNote1 = "0 prices products are red. Do you want white color back?"

Answer1 = MsgBox(MyNote1, vbQuestion + vbYesNo, "0 prices products")

If Answer1 = vbNo Then

Else
'________________________________
'TURNING OFF THE BACKGROUND COLOR

For Each c In ActiveSheet.UsedRange
If c.Interior.ColorIndex = 3 Then
c.Interior.ColorIndex = xlNone
End If
Next c

End If
End If
Next I1
End With

'________________________________________________
'FIND TRANSLATED PRODUCTS AND MARK THEM BY COLOR

MySearch = Array("EN")
myColor = Array("6")

Application.ScreenUpdating = False


Columns("O:O").Select
Selection.EntireColumn.Hidden = False

With Sheets("cennik_SET").Range("O:O")

For I = LBound(MySearch) To UBound(MySearch)

Set Rng = .Find(what:=MySearch(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rng.Offset(0, -3).Interior.ColorIndex = myColor(I)
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address < FirstAddress


Columns("O:O").Select
Selection.EntireColumn.Hidden = True

Application.ScreenUpdating = True

'MESSAGE

MyNote = "Translated products are yellow. Do you want white color back?"

Answer = MsgBox(MyNote, vbQuestion + vbYesNo, "No translation")

If Answer = vbNo Then

Else
'________________________________
'TURNING OFF THE BACKGROUND COLOR

For Each c In ActiveSheet.UsedRange
If c.Interior.ColorIndex = 6 Then
c.Interior.ColorIndex = xlNone
End If
Next c

End If
End If
Next I

End With


End If

End Sub

'______________

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$244" Then
ActiveSheet.PivotTables("Tabela przestawna2").PivotCache.Refresh
End If
End Sub
.