Hi

I need a little guidance with some VBA coding.

I'm trying to look down one column to find an input value of the
'contains' type. Once found , the equivalent values in a second column
would be amended to an input value.

It would run like this :

Input 1 - Choose Column to search on
Input 2 - Choose 'contains' value
Input 3 - Choose column to amend
Input 4 - Lower Value in amend column
Input 5 - Upper Value in amend column
Input 6 - Value to amend to

For example

A F

12345_LP34 9.5
45234_LP67 3.5
42525_OY43 7.5

Would become

12345_LP34 9.5
45234_LP67 6.5
42525_OY43 7.5

Where the first input column contains *LP* and the second input column
is between 0 and 5.


Grateful for any help.

Hi Colin,

Am Mon, 14 Jul 2014 15:34:41 +0100 schrieb Colin Hayes:

A F

12345_LP34 9.5
45234_LP67 3.5
42525_OY43 7.5

Would become

12345_LP34 9.5
45234_LP67 6.5
42525_OY43 7.5

enter into the InputBox e.g.:
A;LP;F;0;5;6.5

Sub ReplaceVal()
Dim strCond As String, FirstAddress As String
Dim arrCond As Variant
Dim LRow As Long
Dim c As Range

strCond = Application.InputBox("Please enter the column to search on, "
_
& "the substring, the column to amend, the lower value, the upper
value " _
& " the value to amend semocolon-separated", "Enter Conditions",
Type:=2)

arrCond = Split(strCond, ";")
LRow = Cells(Rows.Count, Asc(UCase(arrCond(0))) - 64).End(xlUp).Row

Set c = Range(Cells(1, Asc(UCase(arrCond(0))) - 64), Cells(LRow,
Asc(UCase(arrCond(0))) - 64)) _
.Find(arrCond(1), LookIn:=xlValues, lookat:=xlPart)

If Not c Is Nothing Then
FirstAddress = c.Address
Do
If c.Offset(, Asc(UCase(arrCond(2))) -
Asc(UCase(arrCond(0)))) _
CDbl(arrCond(3)) And c.Offset(, Asc(UCase(arrCond(2))) - _
Asc(UCase(arrCond(0)))) < CDbl(arrCond(4)) Then
c.Offset(, Asc(UCase(arrCond(2))) -
Asc(UCase(arrCond(0)))) _
= CDbl(arrCond(5))
c.Offset(, Asc(UCase(arrCond(2))) -
Asc(UCase(arrCond(0)))) _
.Font.Color = vbRed
End If
Set c = Range(Cells(1, Asc(UCase(arrCond(0))) - 64), _
Cells(LRow, Asc(UCase(arrCond(0))) - 64)).FindNext(c)
Loop While Not c Is Nothing And c.Address < FirstAddress
End If
End Sub


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

In article , Claus Busch
enter into the InputBox e.g.:
A;LP;F;0;5;6.5

Sub ReplaceVal()
Dim strCond As String, FirstAddress As String
Dim arrCond As Variant
Dim LRow As Long
Dim c As Range

strCond = Application.InputBox("Please enter the column to search on, "
_
& "the substring, the column to amend, the lower value, the upper
value " _
& " the value to amend semocolon-separated", "Enter Conditions",
Type:=2)

arrCond = Split(strCond, ";")
LRow = Cells(Rows.Count, Asc(UCase(arrCond(0))) - 64).End(xlUp).Row

Set c = Range(Cells(1, Asc(UCase(arrCond(0))) - 64), Cells(LRow,
Asc(UCase(arrCond(0))) - 64)) _
.Find(arrCond(1), LookIn:=xlValues, lookat:=xlPart)

If Not c Is Nothing Then
FirstAddress = c.Address
Do
If c.Offset(, Asc(UCase(arrCond(2))) -
Asc(UCase(arrCond(0)))) _
CDbl(arrCond(3)) And c.Offset(, Asc(UCase(arrCond(2))) - _
Asc(UCase(arrCond(0)))) < CDbl(arrCond(4)) Then
c.Offset(, Asc(UCase(arrCond(2))) -
Asc(UCase(arrCond(0)))) _
= CDbl(arrCond(5))
c.Offset(, Asc(UCase(arrCond(2))) -
Asc(UCase(arrCond(0)))) _
.Font.Color = vbRed
End If
Set c = Range(Cells(1, Asc(UCase(arrCond(0))) - 64), _
Cells(LRow, Asc(UCase(arrCond(0))) - 64)).FindNext(c)
Loop While Not c Is Nothing And c.Address < FirstAddress
End If
End Sub


Regards
Claus B.

Hi Claus


OK - Fantastic. I don't know how you do it. Many many thanks.

BTW , it did initially give an 'End IF without Block IF' error.

I remmed this and it seems to run fine anyhow.



Best Wishes


Colin

Hi Colin,

OK - Fantastic. I don't know how you do it. Many many thanks.

the following code handles errors and it is better to understand and
modify:

Sub ReplaceVal2()
Dim strCond As String, FirstAddress As String
Dim arrCond As Variant
Dim LRow As Long
Dim c As Range
Dim SCol As Long, ACol As Long

strCond = Application.InputBox("Please enter the column to search on, "
_
& "the substring, the column to amend, the lower value, the upper
value " _
& " and the value to amend semicolon-separated", "Enter Conditions",
Type:=2)

If strCond = "" Or strCond = "False" Then Exit Sub

arrCond = Split(strCond, ";")
SCol = Asc(UCase(arrCond(0))) - 64
ACol = Asc(UCase(arrCond(2))) - 64
LRow = Cells(Rows.Count, SCol).End(xlUp).Row

Set c = Range(Cells(1, SCol), Cells(LRow, SCol)) _
.Find(arrCond(1), LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
If c.Offset(, ACol - SCol) CDbl(arrCond(3)) And _
c.Offset(, ACol - SCol) < CDbl(arrCond(4)) Then
c.Offset(, ACol - SCol) = CDbl(arrCond(5))
c.Offset(, ACol - SCol).Font.Color = vbRed
End If
Set c = Range(Cells(1, SCol), Cells(LRow, SCol)).FindNext(c)
Loop While Not c Is Nothing And c.Address < FirstAddress
End If
End Sub


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

Not to take away from Claus' offering!
In my usual approach to avoid read/write directly from/to worksheets...


Sub FindReplace()
Dim vVals, vRng, sMsg$, n&, lLastRow&, lOffset&
Dim rngSource As Range

sMsg = "Please enter the label of column to search on, " _
& "the substring to search for, " _
& "the label of column to amend, " _
& "the lower value, " _
& "the upper value the value to amend semocolon-separated"
vVals = _
Split(Application.InputBox(sMsg, "Enter Conditions", Type:=2), ";")

'Validate input
' If user cancels OR returns an empty string
' OR If missing args
If UBound(vVals) < 5 Then Exit Sub

On Error GoTo ErrExit
lLastRow = Cells(Rows.Count, vVals(0)).End(xlUp).Row
Set rngSource = Range(Cells(1, vVals(0)), Cells(lLastRow, vVals(2)))
vRng = rngSource: lOffset = UBound(vRng, 2)

For n = LBound(vRng) To UBound(vRng)
If InStr(vRng(n, 1), vVals(1)) 0 Then
If vRng(n, lOffset) CDbl(vVals(3)) _
And vRng(n, lOffset) < CDbl(vVals(4)) _
Then vRng(n, lOffset) = CDbl(vVals(5))
End If
Next 'n
rngSource = vRng

ErrExit:
Set rngSource = Nothing
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

In article , Claus Busch
writes
Sub ReplaceVal2()
Dim strCond As String, FirstAddress As String
Dim arrCond As Variant
Dim LRow As Long
Dim c As Range
Dim SCol As Long, ACol As Long

strCond = Application.InputBox("Please enter the column to search on, "
_
& "the substring, the column to amend, the lower value, the upper value " _
& " and the value to amend semicolon-separated", "Enter Conditions", Type:=2)

If strCond = "" Or strCond = "False" Then Exit Sub

arrCond = Split(strCond, ";")
SCol = Asc(UCase(arrCond(0))) - 64
ACol = Asc(UCase(arrCond(2))) - 64
LRow = Cells(Rows.Count, SCol).End(xlUp).Row

Set c = Range(Cells(1, SCol), Cells(LRow, SCol)) _
.Find(arrCond(1), LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
If c.Offset(, ACol - SCol) CDbl(arrCond(3)) And _
c.Offset(, ACol - SCol) < CDbl(arrCond(4)) Then
c.Offset(, ACol - SCol) = CDbl(arrCond(5))
c.Offset(, ACol - SCol).Font.Color = vbRed
End If
Set c = Range(Cells(1, SCol), Cells(LRow, SCol)).FindNext(c)
Loop While Not c Is Nothing And c.Address < FirstAddress
End If
End Sub

Hi

OK thanks again - it's working perfectly.

Out of curiosity , is there a way to rotate random colours in a macro do
you know?

For example , this code marks changed cells in red.

If I run it again , can it be made to choose a different colour so that
the results are distinct one from another? Just wondering.



Best Wishes

Sorry I didn't catch that you wanted to 'flag' amended cells! The
following revision will apply random Font.Color (simple method) to
amended cells for each run...

Sub FindReplace2()
Dim vVals, vRng, sMsg$, n&, k&, lLastRow&, lOffset&
Dim rngSource As range, vNdxs(), bAmends As Boolean

sMsg = "Please enter the label of column to search on, " _
& "the substring to search for, " _
& "the label of column to amend, " _
& "the lower value, " _
& "the upper value the value to amend semocolon-separated"
vVals =
Split(Application.InputBox(sMsg, "Enter Conditions", Type:=2), ";")

'Validate input
' If user cancels or returns an empty string
' OR If missing args
If UBound(vVals) < 5 Then Exit Sub

On Error GoTo ErrExit
lLastRow = Cells(Rows.Count, vVals(0)).End(xlUp).Row
Set rngSource = range(Cells(1, vVals(0)), Cells(lLastRow, vVals(2)))
vRng = rngSource: lOffset = UBound(vRng, 2)

For n = LBound(vRng) To UBound(vRng)
If InStr(vRng(n, 1), vVals(1)) 0 Then
If vRng(n, lOffset) CDbl(vVals(3)) _
And vRng(n, lOffset) < CDbl(vVals(4)) Then
vRng(n, lOffset) = CDbl(vVals(5))
ReDim Preserve vNdxs(k)
vNdxs(k) = n: k = k + 1: bAmends = True
End If
End If
Next 'n
rngSource = vRng: If bAmends Then FlagCells vNdxs, vVals(2)

ErrExit:
Set rngSource = Nothing
End Sub

Sub FlagCells(RowNums(), ByVal ColLabel$)
' Applys a random RGB value to Font.Color
' of specified cells in a specified column.

Dim vRGB(2), n&
Const lMin& = 0: Const lMax& = 255
For n = LBound(vRGB) To UBound(vRGB)
vRGB(n) = Int((lMax - lMin + 1) * Rnd + lMin)
Next 'n
For n = LBound(RowNums) To UBound(RowNums)
Cells(RowNums(n), ColLabel).Font.Color = _
RGB(vRGB(0), vRGB(1), vRGB(2))
Next 'n
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

Hi Colin,

Am Mon, 14 Jul 2014 21:16:53 +0100 schrieb Colin Hayes:

Out of curiosity , is there a way to rotate random colours in a macro do
you know?

not all colors are good readable on white background. So I would avoid
random colors. In the following code I inserted an array of 12 fix
colors. After the 12. run the colors are starting new. I hope 12 colors
are enough colors for your project:

Sub ReplaceVal2()
Dim strCond As String, FirstAddress As String
Dim arrCond As Variant, arrClrs As Variant
Dim LRow As Long
Dim c As Range
Dim SCol As Long, ACol As Long

strCond = Application.InputBox _
("Please enter the column to search on, " _
& "the substring, the column to amend, the lower value, " _
& "the uppervalue and the value to amend semicolon-separated", _
"Enter Conditions", Type:=2)

If strCond = "" Or strCond = "False" Then Exit Sub

Application.ScreenUpdating = False

arrCond = Split(strCond, ";")
If UBound(arrCond) < 5 Then Exit Sub

SCol = Asc(UCase(arrCond(0))) - 64
ACol = Asc(UCase(arrCond(2))) - 64
LRow = Cells(Rows.Count, SCol).End(xlUp).Row
arrClrs = Array(3, 4, 5, 6, 10, 11, 25, 26, 32, 45, 46, 55)

Set c = Range(Cells(1, SCol), Cells(LRow, SCol)) _
.Find(arrCond(1), LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
If c.Offset(, ACol - SCol) CDbl(arrCond(3)) And _
c.Offset(, ACol - SCol) < CDbl(arrCond(4)) Then
c.Offset(, ACol - SCol) = CDbl(arrCond(5))
c.Offset(, ACol - SCol).Font.ColorIndex =
arrClrs(Range("XFD1").Value)
End If
Set c = Range(Cells(1, SCol), Cells(LRow, SCol)).FindNext(c)
Loop While Not c Is Nothing And c.Address < FirstAddress
End If
Range("XFD1") = IIf(Range("XFD1") = 11, 0, Range("XFD1") + 1)

Application.ScreenUpdating = True
End Sub




Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

In article , Claus Busch
writes
Hi Colin,

Am Mon, 14 Jul 2014 21:16:53 +0100 schrieb Colin Hayes:

Out of curiosity , is there a way to rotate random colours in a macro do
you know?

not all colors are good readable on white background. So I would avoid
random colors. In the following code I inserted an array of 12 fix
colors. After the 12. run the colors are starting new. I hope 12 colors
are enough colors for your project:


HI

OK thanks for this.

I'm getting an error : 'Method of range of object global failed'.

It seems to be in this line :

c.Offset(, ACol - SCol).Font.ColorIndex = arrClrs(Range("XFD1").Value)

Any ideas on this?



Best Wishes



Sub ReplaceVal2()
Dim strCond As String, FirstAddress As String
Dim arrCond As Variant, arrClrs As Variant
Dim LRow As Long
Dim c As Range
Dim SCol As Long, ACol As Long

strCond = Application.InputBox _
("Please enter the column to search on, " _
& "the substring, the column to amend, the lower value, " _
& "the uppervalue and the value to amend semicolon-separated", _
"Enter Conditions", Type:=2)

If strCond = "" Or strCond = "False" Then Exit Sub

Application.ScreenUpdating = False

arrCond = Split(strCond, ";")
If UBound(arrCond) < 5 Then Exit Sub

SCol = Asc(UCase(arrCond(0))) - 64
ACol = Asc(UCase(arrCond(2))) - 64
LRow = Cells(Rows.Count, SCol).End(xlUp).Row
arrClrs = Array(3, 4, 5, 6, 10, 11, 25, 26, 32, 45, 46, 55)

Set c = Range(Cells(1, SCol), Cells(LRow, SCol)) _
.Find(arrCond(1), LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
If c.Offset(, ACol - SCol) CDbl(arrCond(3)) And _
c.Offset(, ACol - SCol) < CDbl(arrCond(4)) Then
c.Offset(, ACol - SCol) = CDbl(arrCond(5))
c.Offset(, ACol - SCol).Font.ColorIndex =
arrClrs(Range("XFD1").Value)
End If
Set c = Range(Cells(1, SCol), Cells(LRow, SCol)).FindNext(c)
Loop While Not c Is Nothing And c.Address < FirstAddress
End If
Range("XFD1") = IIf(Range("XFD1") = 11, 0, Range("XFD1") + 1)

Application.ScreenUpdating = True
End Sub




Regards
Claus B.

Hi Colin,

Am Tue, 15 Jul 2014 14:46:40 +0100 schrieb Colin Hayes:

c.Offset(, ACol - SCol).Font.ColorIndex = arrClrs(Range("XFD1").Value)

do you work with xl2003 or older?
Change "XFD1" to "IV1"


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

In article , Claus Busch
writes
Hi Colin,

Am Tue, 15 Jul 2014 14:46:40 +0100 schrieb Colin Hayes:

c.Offset(, ACol - SCol).Font.ColorIndex = arrClrs(Range("XFD1").Value)

do you work with xl2003 or older?
Change "XFD1" to "IV1"


Regards
Claus B.

Hi Claus

Yes , I have 2003 here.

OK all good now - thanks again



Best Wishes

In article , GS writes
Sorry I didn't catch that you wanted to 'flag' amended cells! The
following revision will apply random Font.Color (simple method) to
amended cells for each run...


Hi Garry

OK thanks for this. I'm grateful again for your time and considerable
expertise.



Best Wishes



Sub FindReplace2()
Dim vVals, vRng, sMsg$, n&, k&, lLastRow&, lOffset&
Dim rngSource As range, vNdxs(), bAmends As Boolean

sMsg = "Please enter the label of column to search on, " _
& "the substring to search for, " _
& "the label of column to amend, " _
& "the lower value, " _
& "the upper value the value to amend semocolon-separated"
vVals =
Split(Application.InputBox(sMsg, "Enter Conditions", Type:=2), ";")

'Validate input
' If user cancels or returns an empty string
' OR If missing args
If UBound(vVals) < 5 Then Exit Sub

On Error GoTo ErrExit
lLastRow = Cells(Rows.Count, vVals(0)).End(xlUp).Row
Set rngSource = range(Cells(1, vVals(0)), Cells(lLastRow, vVals(2)))
vRng = rngSource: lOffset = UBound(vRng, 2)

For n = LBound(vRng) To UBound(vRng)
If InStr(vRng(n, 1), vVals(1)) 0 Then
If vRng(n, lOffset) CDbl(vVals(3)) _
And vRng(n, lOffset) < CDbl(vVals(4)) Then
vRng(n, lOffset) = CDbl(vVals(5))
ReDim Preserve vNdxs(k)
vNdxs(k) = n: k = k + 1: bAmends = True
End If
End If
Next 'n
rngSource = vRng: If bAmends Then FlagCells vNdxs, vVals(2)

ErrExit:
Set rngSource = Nothing
End Sub

Sub FlagCells(RowNums(), ByVal ColLabel$)
' Applys a random RGB value to Font.Color
' of specified cells in a specified column.

Dim vRGB(2), n&
Const lMin& = 0: Const lMax& = 255
For n = LBound(vRGB) To UBound(vRGB)
vRGB(n) = Int((lMax - lMin + 1) * Rnd + lMin)
Next 'n
For n = LBound(RowNums) To UBound(RowNums)
Cells(RowNums(n), ColLabel).Font.Color = _
RGB(vRGB(0), vRGB(1), vRGB(2))
Next 'n
End Sub

Hi Garry

OK thanks for this. I'm grateful again for your time and considerable
expertise

Glad to help!

As Claus said.., some colors may not work with the normal cell shade.
My hope was to keep in the zone of darker tones by increasing the RGB
factor by a fixed amount, so you might want to play with that!

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion