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
0
gordom
1/19/2010 12:05:15 PM
excel.programming 6508 articles. 2 followers. Follow

4 Replies
1120 Views

Similar Articles

[PageSpeed] 19

Hi Gordom,
Although I am not entirely sure what’s 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 didn’t 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
> .
> 
0
Utf
1/19/2010 9:04:01 PM
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 what’s 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 didn’t 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
>> .
>>

0
gordom
1/20/2010 4:11:46 PM
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 what’s 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 didn’t 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
0
Utf
1/20/2010 5:51:01 PM
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 what’s 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 didn’t 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

0
gordom
1/20/2010 11:05:28 PM
Reply:

Similar Artilces:

Intercept ShutDown Event in C# ? Problem with error code 0xC000014
Hi all, I am trying to write application which will intercept ShutDown event and then cancel that even do some backup work and then fire again shut down event. The problem I am facing is that after capturing shutdown event following line does not help me to cancel it completlly: System.Diagnostics.Process.Start(@"C:\WINNT\system32\shutdown.exe", "-a"); So ShutDown seems to be canceld but my application report error code 0xC0000142 in User32.dll, and can not proceed with backup operation. Is there any way to cancel shutdown event and that application have a...

Problem after Changing the Domain Admin password
After changing the password for the domain admin users cannot log into outlook but can open WEBMAIL. If i change the admin password back and restart the the Exhange services everyone can once again log into their outlook. It is Exchange 2000 on a windows 2000 server. The exchange services are set to use the local system account. Any suggestions. ...

Outlook Office assittant problem
hi all When i start and stop the outlook 2000, i am getting the following alert message "There are no Office Assistant character files present on the system. Please run setup in maintenance mode and install at least one character" but by clicking "Ok" , the outlook continues to work. what can be done for avoiding this alet? Thanks and redgs neela The program is asking that the original installation media be placed back in the machine, go to the add/remove applet in the control panel, highlight Office/Outlook 2000, and select Add/Remove. From there it wants y...

Parameter Query Problem 12-21-07
Hi, I'm creating a Paramater Query based on the date of a payment and receipt number for a record which includes 1st payment, second payment, and 3rd payment and 1st receipt number, 2nd receipt number, and 3rd receipt number fields. How do I retrieve only the field results which match the parameter criteria without pulling up other field values of that record which may not fit the search criteria? Thank you for any suggestions. I suggest that you change you table structure to something like this --- Payments --- PayID - autonumber Invoice - (could be SalesID - relates to sale &...

imap problems through front end
I am having problems with imap through the front end server. the front end server is in an dmz and back end in the private network. so a user from the public net tried imap through front end using outlook express and gets an error The requested name is valid, but no data of the requested type was found. any ideas? even ms support does not even know I dont want to have to relocate my front end server help please Hi Tony, Is the IMAP service running on the backend also? This is a requirement. If IMAP, POP, etc is running on the front end it also needs to be running on the back ...

Inconsistent rule problem
I have a rule set up that automatically forwards specific emails as an attachment. The problem is that sometimes an email will come in the rule will send it off and then the email is marked as read, at other times it's marked as unread. Is there anyway to make sure that the email will read unread until I actually read it? -- ejames See my reply to your post in microsoft.public.outlook.general. -- Jocelyn Fiorello MVP - Outlook *** Messages sent to my e-mail address will NOT be answered -- please reply only to the newsgroup to preserve the message thread. *** "ejames"...

Pay Code Inactive for Employee
I must be missing something, but is there a way to inactive a pay code for a particular employee if it no longer applies to that particular employee, but is still used for other employees? Just go to Cards >> Payroll >> Pay Codes and mark the inactive box. -- Charles Allen, MVP "Hutch" wrote: > I must be missing something, but is there a way to inactive a pay code for a > particular employee if it no longer applies to that particular employee, but > is still used for other employees? Thanks. I had mistaken that for setting the employee inactive and no...

Problem loading outlook
Hi Guys Everytime I start Outlook 2003 I get the following error: A runtime error has occurred. Do you wish to debug? Line:297 Error: Class not registerd. If I click yes I am asked which Just-in-time debugger I want to use. I select Microsoft Script Editor 6.0 and get the following message: An excpetion of type 'Class not registered' was not handled and then the following is highlighted: document.all.dateScript.innerHTML = window.external.GetDate(); Any help please -- Thanks TJ Try a new mail profile. --� Milly Staples [MVP - Outlook] Post all replies to the group t...

gmail.com sending problem
hi... i am using a exchange server 2000 all mail send/receive is working properly but gmail.com domain sending problem when any user send mail to gmail domain users of gmail receives quiet late about after 10 hours. Any way to check why gmail domain problem quite late in queue. Thanks in advance If you look at the headers in GMail of a message that was sent from your domain, you should be able to tell from the time stamps where the delay is....once you know where, you can then focus on why... "Hyder Abbas" <Hyder Abbas@discussions.microsoft.com> wrote in message ne...

Outlook & OWA Language problem
We have a client running Outlook 2003 and IE 6 for OWA. Both clients have the inbox (and several other folders) in spanish. It should be in english. Have checked the local machines for different languages. (yes this happens on every machine she logs into and at home using OWA). We have already run: outlook.exe /ResetFolders outlook.exe /ResetFolderNames These switches did nothing. We also did a repair on the Office 2003 install, uninstalled office and reinstalled it...Still the same. The exchange servers do have anti-virus software running but it's not effecting the other 48,000+ users. ...

Problems downloading transactions #2
For some reason I can't download transactions for my Wells Fargo accounts through MS Money 2007 anymore. It seems that there were two options in the past, 1 was to download them through MS Money for free or 2, pay for Online banking with Wells Fargo which gives you bill pay. Wells Fargo said they don't support option 1 and it was done through MS Money. Is this option no longer available through Money? I recently had this problem pop up, too. Within the past week, whenever I try to download my information through MS Money (as I have for a few years) it has not permitted me to do so...

Summing problem
Hi I have have few columns which have several rows. Each column has been added up using the Sigma tool (S). When I try to add up ( = A+B+C...) those sums I end up with zero value no matter what I do? Any ideas? Thanks Kalevi Hi Kalevi, > I have have few columns which have several rows. Each column has been added > up using the Sigma tool (S). When I try to add up ( = A+B+C...) those sums I > end up with zero value no matter what I do? > Any ideas? > You mean =A10+B10+C10 ? (or =SUM(A10:C10)) Regards, Jan Karel Pieterse Excel MVP www.jkp-ads.com Just a guess .. Perha...

Sorting Problem 03-19-07
I deleted a previous question on this, but I now can't view the thread. Please accept my appology. I need to start again. Field: DBxInst: ([DBNum]*1000)+[Inst Num] Field: TheSortOrder: IIf([Forms]![boxSeatsForITI]![MySortOrder]=1,[BankName],[DBxInst]) The Sorting and Grouping window contains TheSortOrder. When MySortOrder = 1, the report is sorted correctly by [BankName]. When MysortOrder = 2, the report is not sorted by [BankName], nor is it sorted by [DBxInst], because the value of DBxInst is WRONG. But if I put [DBxInst] in the Sorting and Grouping window instead of MySortOrde...

Strange CListCtrl Sorting problem
Hi All, Here is the situation. I have a list control that get's populated after the user selects an item from a combo box. Each time the user selects a new item from the combobox I remove all the items and add new ones. Now depending on the combo box item selected, the list needs to be sorted or not. So I have a m_Sort flag that get's set everytime the ComboBox selection is changed, and after I populate the CListCtrl I call SortItems if the m_Sort flag is set to true. If the first time I populate the CListCtrl and sort it, then everytime I clear it an add items they are all sorte...

WSAEPROVIDERFAILEDINIT problem from service
I run from service process with user rights (when user is logged) and in this process I create socket (CAsyncSocket::Create(port);). And I get WSAEPROVIDERFAILEDINIT error. When I run this process manually everything is ok. What is wrong? There are issues of server privileges involved. One thing you might try is to use other than the LocalService account to run the service. joe On Tue, 11 Oct 2005 17:37:45 +0200, ragi <ragi@agora.pl> wrote: >I run from service process with user rights (when user is logged) and in >this process I create socket (CAsyncSocket::Create(port)...

Problems with installing Outlook client user terminal server
Dear all, We are having problems installing the Outlook client on our Terminal service environment. The web client works great but when Outlook is started it crashes straight away and we get error messages in the server event log "There was a problem connecting to the authenticating server". Do you know the "log in" diference between CRM using Outlook and CRM using web client ? Is it possible that the system is trying to log into other services than the web client does typically ? ...

Problem re-loading Office 2003
I have a fully certified copy of Office 2003 which was working fine and no problems at all - but after the hard-drive failed on my Vaio pc - I had to use the emergency disc to recover the XP system after a new hard-drive was installed. All my old programmes loaded like a dream - except Office 2003 that started the set up and then an error message came up - Waiting for cabinets to be cached - then missing file L2561412 and set up failed. I trawled through the web to try and find a solution and someone suggested that this was because 2003 was not locating the CD drive to locate...

Outlook & Outlook Express
I have both loaded on my computer (Express was my original e-mail program). I successfully loaded Outlook and copied my contact list. I then set Outlook as the default. Nevertheless, I only get mail on O-Express, even though all my settings on Outlook, Outlook-Express list Outlook as the default. Mail settings on my control panel verify this. What's wrong??? Firstly with OE closed does OL send/receive OK ie send yourself a msg If OK, either delete mail accounts in OE, or set it to not check for mail. If you use OE (mail) and OL whichever is open will receive mail, assuming the ...

Problem with ExportAsFixedFormat with selected sheets
I have the routine below in a number of workbooks. Typically it works without a problem. I have a sheet with sheet names that I select and it exports the sheets to a PDF. For some reason sometimes it only produces a PDF with the first sheet in it instead of all sheetnames that were selected. I have made sure the sheetname array has more than one value and have also made sure (by exiting before the export) that it is selecting the correct sheets in a group. Both of those work fine. I have also made sure that there was not a problem with the SortableDateString fuction. If I manually select th...

Word merge code
I have been using this code for a while with Office 2000. I recently moved to Office 2003 and when you click on "OK Merge to Word" MS Word does open up but with a blank document. In other word the merge failed. Does anyone know what changes need to be made for Ofiice 2003 and this code. Thanks Hi Eric I have just looked at Alberts RunWord module and if it opens word ok then it would seem (I may be wrong) that the problem is not with the code. Have you you moved the location of the word docs ? It is prob the onclick action (or other event) you are using. Try this - ...

Solution to IE8/Google redirect problem
My Google search results were sending me to different webpages. I searched numerous forums for solutions. I used Spybot, Malwarebytes, HiJackThis, and other suggestions, with no success. Finally, I downloaded the free version of HitmanPro 3.5. HP3.5 identified atapi.sys as "Rootkit". Deleted and redirect problem went away. I hope this works for you! Hi, Have you rebooted since you Deleted and redirect problem went away? Rootkit infections usually aren't that easy to remove. Even a nuke and pave is not enough. Web search for rootkit infections You sho...

URL/link problems, isv.config, window.dialogArguments
Hi, I created a new webSite (and virtual directory) in the same server of CRM (3.0) but another port (I can´t keep CRM and my webSite in the same port). I changed the isv.config and add a button with a URL that link to page in my webSite: <ToolBar ValidForCreate="0" ValidForUpdate="1"> <Button Title="CORPORE --> CRM" Url="http://myServerNname:85/Corpore.NET/CRMMSIntegraAlunoCorporeCRMMSProcessando.aspx" PassParams="1" WinParams="dialogHeight: 400px; dialogWidth: 600px; dialogTop: px; dialogLeft: px; edge:...

Outlook Express problem
I am expereiencing problems with outlook express - all of my mail messages both in the inbox and sent are now appearing blank - although the content is there and can be accesed by using the save attachment option. Can anybody advise what is wrong and how I can fix this problem - Running Windows ME. and Outlook express 6 ...

Access 2k code doesn't run under Vista/A2k7
I have a new client who has an Access 2000 database that used to run under Windows 2000 Pro. They have just "upgraded" to Access 2007 under Vista, and the old database stopped working - buttons on forms did nothing. When I first looked at it the problem seemed to be the change to the signature of Docmd.Requery (fewer arguments) so I made the necessary changes and the database compiled. I compiled and tested it on my work system (also Vista, A2k7) and it worked fine. When I copied the db onto the client's machine, it didn't work. I checked that it compiled correctly (it d...

Outlook 98 problem with attachments
Having some trouble viewing an email in outlook 98 with an attachment. I received an email from a sender with a print screen image. When I open the email I can't see it at all, just a box with a red "x" it's like outlook doesn't recognize it. If he manually attaches it--then I can see it, but if he just starts a new message and does a ctrl+V to paste the print screen into the email message body I can not view it. I also noticed that if he uses the latter of the method by just pasting the print screen into the body of the message I also don't get a "paperclip&...