Problem with the code, probably with Private Sub Worksheet_Calculate()
 

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

Problem with the code, probably with Private Sub Worksheet_Calcula
 

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
.

Problem with the code, probably with Private Sub Worksheet_Calcula
 

Thank you very much for your help. The code works fine, almost
perfectly. It does everything I need and Excel doesn't hang. The only
problem is that macro shows message boxes (the result of executing
MarkZeroPrices("Sheet2") and MarkTranslatedProducts("Sheet2") functions)
every time. It means that the messages are also displayed if there are
no values within the worksheet we are looking for. In spite of the fact
that none of the cells were highlighted (the values weren't found), we
get a prompt that it was done. Could you please tell me how to avoid
that, it's a little bit confusing. I would like to get the messages only
if these values are found in fact. Otherwise the prompt is not
necessary. I tried to do some modification on my own but again without
any positive result :(.
And in the end few words to explain the "background" of this macro. It's
basically meant to format a data which are imported from a pivot table.

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

Exactly. It is a kind of walk around to replace a PivotTableUpdate Sub,
which is as far as I know not supported in Excel 2000. Let say it's a
trigger to start a macro when data in the pivot are changed.


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

Macro want start again until pivot will be changed.

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

This fragment force a delay in executing macro procedures. I should
delete these lines but I forgot. It was just for testing. Thank you very
much once again. Regards,
Gordom

W dniu 2010-01-19 22:04, Jeff pisze:
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
.

Problem with the code, probably with Private Sub Worksheet_Cal
 

Ok, I have added the code so if no cells containing the values your searching
for no msgBox will appear. But if the value are found it prompts the user to
keep the formating. HTH.

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")

' Mark translated 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 Not aFoundCell Is Nothing Then
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 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 Not aFoundCell Is Nothing Then
If vbNo < MsgBox("Translated products are yellow. Do you want white
color back?", _
vbQuestion + vbYesNo, "") Then
ResetInteriorColor Ws.Name, 6
End If
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

"gordom" wrote:

Thank you very much for your help. The code works fine, almost
perfectly. It does everything I need and Excel doesn't hang. The only
problem is that macro shows message boxes (the result of executing
MarkZeroPrices("Sheet2") and MarkTranslatedProducts("Sheet2") functions)
every time. It means that the messages are also displayed if there are
no values within the worksheet we are looking for. In spite of the fact
that none of the cells were highlighted (the values weren't found), we
get a prompt that it was done. Could you please tell me how to avoid
that, it's a little bit confusing. I would like to get the messages only
if these values are found in fact. Otherwise the prompt is not
necessary. I tried to do some modification on my own but again without
any positive result :(.
And in the end few words to explain the "background" of this macro. It's
basically meant to format a data which are imported from a pivot table.

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

Exactly. It is a kind of walk around to replace a PivotTableUpdate Sub,
which is as far as I know not supported in Excel 2000. Let say it's a
trigger to start a macro when data in the pivot are changed.


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

Macro want start again until pivot will be changed.

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

This fragment force a delay in executing macro procedures. I should
delete these lines but I forgot. It was just for testing. Thank you very
much once again. Regards,
Gordom

W dniu 2010-01-19 22:04, Jeff pisze:
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

Problem with the code, probably with Private Sub Worksheet_Cal
 

Thank you very, very much. It's perfect now. You helped me a lot :).
Best regards,
Gordom


W dniu 2010-01-20 18:51, Jeff pisze:
Ok, I have added the code so if no cells containing the values your searching
for no msgBox will appear. But if the value are found it prompts the user to
keep the formating. HTH.

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")

' Mark translated 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 Not aFoundCell Is Nothing Then
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 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 Not aFoundCell Is Nothing Then
If vbNo< MsgBox("Translated products are yellow. Do you want white
color back?", _
vbQuestion + vbYesNo, "") Then
ResetInteriorColor Ws.Name, 6
End If
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

"gordom" wrote:

Thank you very much for your help. The code works fine, almost
perfectly. It does everything I need and Excel doesn't hang. The only
problem is that macro shows message boxes (the result of executing
MarkZeroPrices("Sheet2") and MarkTranslatedProducts("Sheet2") functions)
every time. It means that the messages are also displayed if there are
no values within the worksheet we are looking for. In spite of the fact
that none of the cells were highlighted (the values weren't found), we
get a prompt that it was done. Could you please tell me how to avoid
that, it's a little bit confusing. I would like to get the messages only
if these values are found in fact. Otherwise the prompt is not
necessary. I tried to do some modification on my own but again without
any positive result :(.
And in the end few words to explain the "background" of this macro. It's
basically meant to format a data which are imported from a pivot table.

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

Exactly. It is a kind of walk around to replace a PivotTableUpdate Sub,
which is as far as I know not supported in Excel 2000. Let say it's a
trigger to start a macro when data in the pivot are changed.


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

Macro want start again until pivot will be changed.

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

This fragment force a delay in executing macro procedures. I should
delete these lines but I forgot. It was just for testing. Thank you very
much once again. Regards,
Gordom

W dniu 2010-01-19 22:04, Jeff pisze:
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