G
gordom
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
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
.
.