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

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

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