Complex search and replace macro based on input variables.

  • Thread starter Thread starter Colin Hayes
  • Start date Start date
C

Colin Hayes

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
Click to expand...

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))) - _
Click to expand...
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.
 
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)))) _
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.
Click to expand...

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.
Click to expand...

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.
 
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
 
Claus Busch said:
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
Click to expand...

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?
Click to expand...

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.
 
Claus Busch said:
Hi Colin,

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


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:
Click to expand...

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
 
Hi Colin,

Am Tue, 15 Jul 2014 14:46:40 +0100 schrieb Colin Hayes:
c.Offset(, ACol - SCol).Font.ColorIndex = arrClrs(Range("XFD1").Value)
Click to expand...

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


Regards
Claus B.
 
Claus Busch said:
Hi Colin,

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


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


Regards
Claus B.
Click to expand...

Hi Claus

Yes , I have 2003 here.

OK all good now - thanks again



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...
Click to expand...

Hi Garry

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



Best Wishes
 
Hi Garry
OK thanks for this. I'm grateful again for your time and considerable
expertise
Click to expand...

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
 
Back
Top