Expert: Bob Umlas - 10/6/2009

Question
QUESTION: Hi Bob

Help please, my first post to one of these facilities, normally I struggle till I find a solution but this one is beating me and I am running out of time to fix the problem!

I have a complex workbook compiled from 200 individual xls worksheets that is updated monthly, each sheet is set up with the same format but contains different serial number text data in cells c14:c200, e14,e200 and f14:200 an example might be "62606" in c21, "2000562" in e21 and "6553006" on "sheet56" Some of these sheets may only use cells c14:f24 etc whilst others use the full c:14:f200

Each month I add a new  data lookup sheet as "DataLookup" and the data I want to search for is in column A with the range between say a1:a6500.

What I need to do is create a macro that takes the value in the first cell, say a1 contains "6553006" and searches each of the 200 worksheets.

For every exact match it finds, it copies the entire row data to a new worksheet that also includes the "sheetname" it found it on in column A, carries on searching for any other matches and adds those to the new "FoundData" worksheet. Once that search is complete it does the same for the data in a2 etc right through to the end of that range. Normally the data will only be found on one or two individual worksheets for each lookup

The range of data I need to match varies from month to month say from 5500 entries to lookup to 6500 and the matched data might be found in any of the 3 columns.

I am using excel 2003.

Hope that is enough info to go on.

Thanks in advance

Dave

ANSWER: Sub Finder()
Dim Rg As Range, rws As Integer
  On Error Resume Next
  Application.DisplayAlerts = False
  Worksheets("FoundData").Delete
  Set fnd = Worksheets.Add
  fnd.Name = "FoundData"
  For i = 1 To Sheets("DataLookup").Range("A65536").End(xlUp).Row
      For Each sh In Sheets
         If LCase(sh.Name) = "founddata" Or LCase(sh.Name) = "datalookup" Then GoTo NextSh
         Err.Clear
         Set Rg = Nothing
         Set Rg = sh.Cells.Find(Sheets("DataLookup").Cells(i, 1).Value, lookat:=xlWhole)
         If Err.Number = 0 And Not Rg Is Nothing Then 'found
         rws = rws + 1
         sh.Rows(Rg.Row).Copy fnd.Cells(rws, 1)
         Application.CutCopyMode = False
         fnd.Cells(rws, 1).Insert xlToRight
         fnd.Cells(rws, 1).Value = sh.Name
         End If
NextSh:
       Next
   Next
End Sub


---------- FOLLOW-UP ----------

QUESTION: Thanks Bob

I have modified your solution to colour code matched cells on the DataLookup sheet yellow using the interior.colourindex = 6 command, but would also like to colour code the corresponding found cell on the Founddata sheet to interior.colourindex = 7, at the moment I can only get the whole row to colour. Is there an easy way of achieving this? Running this macro process for 5000 entries also seems quite slow, is it possible to speed it up at all, as it is currently taking more than 30 minutes and freezes Excel, whilst it runs.

Thanks in advance

Dave

ANSWER: I'd have to see your modified code to color the cells. You can probably speed this up by putting this statement at the beginning of the macro (after "Sub"):
Application.Calculation=xlcalculationManual
and this before End Sub:
Application.Calculation = xlcalculationAutomatic

Send me your code.

---------- FOLLOW-UP ----------

QUESTION: Hi Bob

Code as below - dont think I am too far away but I only want the cell that is found to be coloured magenta.

Perhaps my syntax is wrong?

This was my first attempt and if the match was in column A it worked fine but it would not colour if match was in column C,F or G.

Sub Finder()
Application.Calculation = xlCalculationManual
Dim rng As Range, rws As Integer
 On Error Resume Next
 Application.DisplayAlerts = False
 Worksheets("FoundData").Delete
 Set fnd = Worksheets.Add
 fnd.Name = "FoundData"
 Application.ScreenUpdating = False
 For i = 1 To Sheets("DataLookup").Range("A65536").End(xlUp).Row
     For Each sh In Sheets
        If LCase(sh.Name) = "founddata" Or LCase(sh.Name) = "datalookup" Then GoTo NextSh
        Err.Clear
        Set rng = Nothing
        Set rng = sh.Cells.Find(Sheets("DataLookup").Cells(i, 1).Value, lookat:=xlWhole)
        If Err.Number = 0 And Not rng Is Nothing Then         'found
        Sheets("DataLookup").Cells(i, 1).Interior.ColorIndex = 6
        Else
        Sheets("DataLookup").Cells(i, 1).Interior.ColorIndex = 3
        End If
        If Err.Number = 0 And Not rng Is Nothing Then         'found
         rws = rws + 1
         sh.Rows(rng.Row).Copy fnd.Cells(rws, 1)
         Application.CutCopyMode = False
         If Sheets("DataLookup").Cells(i, 1).Value = fnd.Cells(rws, 1).Value Then
         fnd.Cells(rws, 1).Interior.ColorIndex = 7
         End If
         fnd.Cells(rws, 1).Insert xlToRight
         fnd.Cells(rws, 1).Value = sh.Name
        End If
NextSh:
      Next
  Next
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End Sub

I then tried this

Sub Finder()
Application.Calculation = xlCalculationManual
Dim rng As Range, rws As Integer
 On Error Resume Next
 Application.DisplayAlerts = False
 Worksheets("FoundData").Delete
 Set fnd = Worksheets.Add
 fnd.Name = "FoundData"
 Application.ScreenUpdating = False
 For i = 1 To Sheets("DataLookup").Range("A65536").End(xlUp).Row
     For Each sh In Sheets
        If LCase(sh.Name) = "founddata" Or LCase(sh.Name) = "datalookup" Then GoTo NextSh
        Err.Clear
        Set rng = Nothing
        Set rng = sh.Cells.Find(Sheets("DataLookup").Cells(i, 1).Value, lookat:=xlWhole)
        If Err.Number = 0 And Not rng Is Nothing Then         'found
        Sheets("DataLookup").Cells(i, 1).Interior.ColorIndex = 6
        Else
        Sheets("DataLookup").Cells(i, 1).Interior.ColorIndex = 3
        End If
        If Err.Number = 0 And Not rng Is Nothing Then         'found
         rws = rws + 1
         sh.Rows(rng.Row).Copy fnd.Cells(rws, 1)
         Application.CutCopyMode = False
         If Sheets("DataLookup").Cells(i, 1).Value = fnd.Cells(rws, 1).Value Then
         fnd.Cells(rws, 1).Interior.ColorIndex = 7
         fnd.Cells(rws, 3).Interior.ColorIndex = 7
         fnd.Cells(rws, 6).Interior.ColorIndex = 7
         fnd.Cells(rws, 7).Interior.ColorIndex = 7
         End If
         fnd.Cells(rws, 1).Insert xlToRight
         fnd.Cells(rws, 1).Value = sh.Name
        End If
NextSh:
      Next
  Next
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End Sub

but this appears to colour blank cells in colums C, F & G once a match has already been found and coloured Magenta in column A.

Thanks in advance   

Regards

Dave

Answer
Change this:
       If Err.Number = 0 And Not rng Is Nothing Then         'found
         rws = rws + 1
         sh.Rows(rng.Row).Copy fnd.Cells(rws, 1)
         Application.CutCopyMode = False
         If Sheets("DataLookup").Cells(i, 1).Value = fnd.Cells(rws, 1).Value Then
         fnd.Cells(rws, 1).Interior.ColorIndex = 7
         fnd.Cells(rws, 3).Interior.ColorIndex = 7
         fnd.Cells(rws, 6).Interior.ColorIndex = 7
         fnd.Cells(rws, 7).Interior.ColorIndex = 7
       End If

to

       If Err.Number = 0 And Not rng Is Nothing Then         'found
         rws = rws + 1
         sh.Rows(rng.Row).Copy fnd.Cells(rws, 1)
         Application.CutCopyMode = False
         For j=1 to 7
         Select Case j
         Case 1,3,6,7
         If Sheets("DataLookup").Cells(i, 1).Value = fnd.Cells(rws, j).Value Then
         fnd.Cells(rws, j).Interior.ColorIndex = 7
         End Select
         Next
        End If