Search other sheets for numbers & color them

L

L. Howard

I have two attempts here that are not falling into place for me.
(The sheet names are a bit goofy, but real names in this test workbook.)

Column G on sheet "name1" gets a list of numbers with several repeats.
On all the other sheets (except sheet "dont touch this sheet") there are many number on each sheet.

For each unique number on sheet "name1" if it occurs on any of the other sheets then color the font the same color. (If I can get it to do the font then I can swap to color the cell if I prefer)

So I have some very scant results with the two attempts below.
First I make a unique list in column F the shoot for a For Each loop on that F column and then a For Each loop on the worksheets and increment the colorindex by 1 for each number, which starts at colorindex 3.

I'm getting a couple of colors on one or two other sheets and some of the different numbers on the others sheet are the same color. Its pretty screwy.

In the second code this errors With Sheets(varSheets(i))

I intend to delete the F column list after the code runs successfully.
I have verified that the numbers are really numbers by using an =SUM(....) on the them.

Thanks,
Howard

Sub SearchColor()
Dim ws As Worksheet
Dim lrow As Long
Dim CheckNum As Range
Dim i As Long
Dim frow As Long
Dim c As Range
Dim cc As Long

lrow = Cells(Rows.Count, "G").End(xlUp).Row
Range("G2:G" & lrow).Copy Range("F" & Rows.Count).End(xlUp)(2)
Range("F2:F" & lrow).RemoveDuplicates 1
frow = Cells(Rows.Count, "G").End(xlUp).Row

For Each CheckNum In Range("F2:F" & frow)
cc = 3
For Each ws In ThisWorkbook.Sheets
If (ws.Name <> "dont touch this sheet") And (ws.Name <> "name1") Then
With ws
Set CheckNum = .UsedRange.Find(What:=CheckNum, LookIn:=xlValues)
If Not CheckNum Is Nothing Then
CheckNum.Font.ColorIndex = cc
' CheckNum.Interior.ColorIndex = cc
End If
End With
End If
Next 'ws
cc = cc + 1
Next 'c
End Sub


Sub ColorNumCells()
Dim ws As Worksheet
Dim lrow As Long
Dim CheckNum As Range
Dim varSheets As Variant
Dim i As Long
Dim frow As Long
Dim cc As Long

lrow = Cells(Rows.Count, "G").End(xlUp).Row
Range("G2:G" & lrow).Copy Range("F" & Rows.Count).End(xlUp)(2)
Range("F2:F" & lrow).RemoveDuplicates 1
frow = Cells(Rows.Count, "G").End(xlUp).Row

varSheets = Array("name", "another name", "etc.", "etc..", "etc....")
cc = 3
For i = LBound(varSheets) To UBound(varSheets)
For Each CheckNum In Range("F2:F" & frow)
With Sheets(varSheets(i)) '/error here

Set CheckNum = .UsedRange.Find(What:=CheckNum, LookIn:=xlValues)

If Not CheckNum Is Nothing Then
'CheckNum.Interior.ColorIndex = cc
CheckNum.Font.ColorIndex = cc
End If

End With
Next 'Each
cc = cc + 1
Next 'i

End Sub
 
G

GS

You need to instantiate separate range vars so you're not
using/changing *CheckNum* in every iteration of your loop. So...

For Each CheckNum...
'..some code
Set CheckNum = .UsedRange.Find(What:=CheckNum...

How about something like this...

For Each CheckNum...
'..some code
Set rngFound = .UsedRange.Find(What:=CheckNum.Value...

-OR-

For Each rng...
'..some code
Set rngFound = .UsedRange.Find(What:=CheckNum.Value...

...not just so *you* know what your code is doing, but so *your code
knows* what it's supposed to be doing!<g>

--
Garry

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

L. Howard

For Each rng...

'..some code

Set rngFound = .UsedRange.Find(What:=CheckNum.Value...



..not just so *you* know what your code is doing, but so *your code

knows* what it's supposed to be doing!<g>
Click to expand...

Thanks for looking in, Garry.

This does not error but also does not do anything. Seems like I should say something like For Each numFnd.Font.ColorIndex = cc but I would think the With ws would do that.

Howard

Sub SearchColor()
Dim ws As Worksheet
Dim lrow As Long
Dim CheckNum As Range
Dim i As Long
Dim frow As Long
Dim c As Range
Dim cc As Long
Dim numFnd As Range

lrow = Cells(Rows.Count, "G").End(xlUp).Row
Range("G2:G" & lrow).Copy Range("F" & Rows.Count).End(xlUp)(2)
Range("F2:F" & lrow).RemoveDuplicates 1
frow = Cells(Rows.Count, "G").End(xlUp).Row

For Each CheckNum In Range("F2:F" & frow)
cc = 3
For Each ws In ThisWorkbook.Sheets
If (ws.Name <> "dont touch this sheet") And (ws.Name <> "name1") Then
With ws
Set numFnd = .UsedRange.Find(What:=CheckNum.Value, LookIn:=xlValues)
If Not numFnd Is Nothing Then
numFnd.Font.ColorIndex = cc
End If
End With
End If
Next 'ws
cc = cc + 1
Next 'c
End Sub
 
G

GS

Try...

Sub SearchColor()
Dim wks As Worksheet
Dim rng, rngFound, vCheckRng
Dim lLastRow&, n&, lFirstRow&, lColor&

Const sSheetsToOmit$ = "dont touch this sheet,name1"

lLastRow = Cells(Rows.Count, "G").End(xlUp).Row
Range("G2:G" & lrow).Copy Range("F" & Rows.Count).End(xlUp)(2)
Range("F2:F" & lrow).RemoveDuplicates 1
lFirstRow = Cells(Rows.Count, "G").End(xlUp).Row

vCheckRng = Range("F2:F" & lFirstRow): lColor& = 3
For n = LBound(vCheckRng) To UBound(vCheckRng)
For Each wks In ThisWorkbook.Sheets
If InStr(1, sSheetsToOmit, wks.Name) = 0 Then
Set rngFound = wks.UsedRange.Find(What:=vCheckRng(n, 1),
LookIn:=xlValues)
If Not rngFound Is Nothing Then
rngFound.Font.ColorIndex = lColor
' rngFound.Interior.ColorIndex = lColor
End If
End If
Next 'ws
lColor = lColor + 1
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
 
L

L. Howard

Sub SearchColor()

Dim wks As Worksheet

Dim rng, rngFound, vCheckRng

Dim lLastRow&, n&, lFirstRow&, lColor&



Const sSheetsToOmit$ = "dont touch this sheet,name1"



lLastRow = Cells(Rows.Count, "G").End(xlUp).Row

Range("G2:G" & lrow).Copy Range("F" & Rows.Count).End(xlUp)(2)

Range("F2:F" & lrow).RemoveDuplicates 1

lFirstRow = Cells(Rows.Count, "G").End(xlUp).Row



vCheckRng = Range("F2:F" & lFirstRow): lColor& = 3

For n = LBound(vCheckRng) To UBound(vCheckRng)

For Each wks In ThisWorkbook.Sheets

If InStr(1, sSheetsToOmit, wks.Name) = 0 Then

Set rngFound = wks.UsedRange.Find(What:=vCheckRng(n, 1),

LookIn:=xlValues)

If Not rngFound Is Nothing Then

rngFound.Font.ColorIndex = lColor

' rngFound.Interior.ColorIndex = lColor

End If

End If

Next 'ws

lColor = lColor + 1

Next 'n

End Sub
Click to expand...
Garry
Click to expand...

Garry,

Getting some scattered results, where a sheet is apparently bypassed, the next has a couple correct colors and the next seems to color one of each of the list in F.

I'm using as test numbers on sheet name1:

1
2
3
1
2
3
1
2
3

and on the other sheets the same list extended by to present some numbers to skip/omit:

6
7
8
6
7
8

The goal being that if there is a 1 on name1 sheet all 1's on all the other sheets should be the same color and the 2's all the same color etc.

The last sheet to have qualifying numbers had the most numbers correctly colored but not all qualifiers were colored.

I was able enough to fix the

Range("G2:G" & lrow).Copy

to

Range("G2:G" & lLastRow).Copy

but not able enough to shake up the code with any confidence.

Howard
 
G

GS

I don't see where you *FindNext* if you expect to find/color all
instances.

Aso, Find should execute on all sheets except those listed in
*sSheetsToOmit* since there can't be 2 sheets with the same name!

--
Garry

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

GS

Perhaps...

Sub SearchColor()
Dim wks As Worksheet, s1stAddr$
Dim rng, rngFound, vCheckRng
Dim lLastRow&, n&, lFirstRow&, lColor&

Const sSheetsToOmit$ = "dont touch this sheet,name1"

lLastRow = Cells(Rows.Count, "G").End(xlUp).Row
Range("G2:G" & lrow).Copy Range("F" & Rows.Count).End(xlUp)(2)
Range("F2:F" & lrow).RemoveDuplicates 1
lFirstRow = Cells(Rows.Count, "G").End(xlUp).Row

vCheckRng = Range("F2:F" & lFirstRow): lColor& = 3
For n = LBound(vCheckRng) To UBound(vCheckRng)
For Each wks In ThisWorkbook.Sheets
If InStr(1, sSheetsToOmit, wks.Name) = 0 Then
With wks.UsedRange
Set rngFound = .Find(What:=vCheckRng(n, 1), LookIn:=xlValues)
If Not rngFound Is Nothing Then
s1stAddr = rngFound.Address
Do
rngFound.Font.ColorIndex = lColor
' rngFound.Interior.ColorIndex = lColor
Set rngFound = .FindNext(rngFound)
Loop While Not rngFound Is Nothing And rngFound.Address <>
s1stAddr
End If 'Not rngFound Is Nothing
End With 'wks.UsedRange
End If 'InStr(1, sSheetsToOmit, wks.Name) = 0
Next 'wks
lColor = lColor + 1
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
 
L

L. Howard

Perhaps...



Sub SearchColor()

Dim wks As Worksheet, s1stAddr$

Dim rng, rngFound, vCheckRng

Dim lLastRow&, n&, lFirstRow&, lColor&



Const sSheetsToOmit$ = "dont touch this sheet,name1"



lLastRow = Cells(Rows.Count, "G").End(xlUp).Row

Range("G2:G" & lrow).Copy Range("F" & Rows.Count).End(xlUp)(2)

Range("F2:F" & lrow).RemoveDuplicates 1

lFirstRow = Cells(Rows.Count, "G").End(xlUp).Row



vCheckRng = Range("F2:F" & lFirstRow): lColor& = 3

For n = LBound(vCheckRng) To UBound(vCheckRng)

For Each wks In ThisWorkbook.Sheets

If InStr(1, sSheetsToOmit, wks.Name) = 0 Then

With wks.UsedRange

Set rngFound = .Find(What:=vCheckRng(n, 1), LookIn:=xlValues)

If Not rngFound Is Nothing Then

s1stAddr = rngFound.Address

Do

rngFound.Font.ColorIndex = lColor

' rngFound.Interior.ColorIndex = lColor

Set rngFound = .FindNext(rngFound)

Loop While Not rngFound Is Nothing And rngFound.Address <>

s1stAddr

End If 'Not rngFound Is Nothing

End With 'wks.UsedRange

End If 'InStr(1, sSheetsToOmit, wks.Name) = 0

Next 'wks

lColor = lColor + 1

Next 'n

End Sub
Click to expand...


I'll give it a go.

I can often find stuff like this that is close to what I think I should be using, but just don't always figure out what to change to suit my scheme.

After about 4 or 5 examples like this that I can't make work (plus my archives) I show up here.

Dim StrSearch As String
Dim rng1 As Range
Dim rng2 As Range

StrSearch = "Force"

With Worksheets(1).UsedRange
Set rng1 = .Find(StrSearch, , xlValues, xlPart)
If Not rng1 Is Nothing Then
strAddress = rng1.Address
Set rng2 = rng1
Do
Set rng1 = .FindNext(rng1)
Set rng2 = Union(rng2, rng1)
Loop While Not rng1 Is Nothing And rng1.Address <> strAddress
End If
End With

Howard
 
L

L. Howard

The last code you offered up works nice.

I changed the name of the sheet named "name" to BadName and the code worked on it too. Not a good name for a sheet.

Thanks, Garry. All the numbers are happy.

Regards,
Howard
 
G

GS

The last code you offered up works nice.
I changed the name of the sheet named "name" to BadName and the code
worked on it too. Not a good name for a sheet.

Thanks, Garry. All the numbers are happy.

Regards,
Howard
Click to expand...

That's great! Thanks for the feedback! Glad I was able to help...

--
Garry

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

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Change event code Find .Activate does not activate Target.value 4
Array code only works on selected sheet 14
Search an array of sheets for an array of numbers & return count of numbers 11
Array VLOOKUP lookup_Value does not increment 3
Expert eye needed 4
Macro to Combine Data from Multiple Sheets with Cell References 4
A simple if <> nn then Msgbox "No Match" 5
Shed some light on this WS_Calculate macro. 3

Top