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