Solved: list data from 53 sheets

[Ger]

i'm using Excel2003 dutch version.
I have a workbook with 53 sheets.
in row 2 from column B to H are date
in row 3 to 20 clolumn B to H can be names

Where i'm looking for is a codes that searches for a name in sheet 1 to 53 and makes a list of the date the name is found.

in the example you can see what i mean.

Thx

Ger

[mdmackillop]

Option Explicit
Sub SearchAll()
Dim cel As Range, i As Long
Dim wsTgt As Worksheet
Set wsTgt = Sheets(1)
For Each cel In wsTgt.Range("B2:B4")
For i = 2 To Sheets.Count
DoFind cel, Sheets(i), wsTgt
Next
Next
End Sub

Sub DoFind(Nme, sh As Worksheet, wsTgt As Worksheet)
Dim FirstAddress As String, c As Range
With sh.Cells
Set c = .Find(Nme.Text, LookIn:=xlValues)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
wsTgt.Cells(Nme.Row, Columns.Count).End(xlToLeft).Offset(, 1).Value _
= sh.Cells(2, c.Column).Value
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
End Sub

[Bob Phillips]

Sub CreateXRef()
Dim i As Long, j As Long, k As Long
Dim LastCol As Long
Dim LastRow As Long
Dim NextRow As Long
Dim FoundRow As Long
Dim sh As Worksheet

Application.ScreenUpdating = False

Application.DisplayAlerts = False
On Error Resume Next
Worksheets("output").Delete
On Error GoTo 0
Application.DisplayAlerts = True

Set sh = Worksheets.Add(before:=Worksheets(1))
sh.Name = "output"
sh.Range("A2").Value = "Name:"
NextRow = 1

For k = 1 To 53

With Worksheets(Format(k, "00"))

For j = 2 To 8

LastRow = .Cells(.Rows.Count, j).End(xlUp).Row
For i = 3 To LastRow

FoundRow = 0
On Error Resume Next
FoundRow = Application.Match(.Cells(i, j).Value2, sh.Columns("B"), 0)
On Error GoTo 0
If FoundRow = 0 Then

NextRow = NextRow + 1
sh.Cells(NextRow, "B").Value2 = .Cells(i, j).Value2
FoundRow = NextRow
End If

LastCol = sh.Cells(FoundRow, sh.Columns.Count).End(xlToLeft).Column
sh.Cells(FoundRow, LastCol + 1).Value2 = .Cells(2, j).Text
Next i
Next j
End With
Next k

Application.ScreenUpdating = True

End Sub

[Ger]

Oke,

it works but...
In output i can have up to 60 names in column B. So i adjusted the range in formula:
For Each cel In wsTgt.Range("B2:B4") in B2:B61.
This gives a result for the rows that have no name in column B.

How can i "kill" this.

Thx


Ger

[Ger]

I just tried the solution of Xld but i have an error on
With Worksheets(Format(k, "00"))

Ger

[mdmackillop]

Try

For Each cel In wsTgt.Range("B2:B61")
If cel<>"" Then
For i = 2 To Sheets.Count
DoFind cel, Sheets(i), wsTgt
Next
End If
Next

[Bob Phillips]

I just tried the solution of Xld but i have an error on
With Worksheets(Format(k, "00"))

Ger

Worked in my test. What error did you get? Do you have worksheets 01 all the way to 53?

[Ger]

Madmickillop,
This works fine. Thx.

I can use the solution from Xld to generate the list the first time. so i can't forget a name. Then i use your solution to update the list.

XLD,

i only had 6 sheets but i adjusted "K". The problem was that i named a sheet 01-2011. I renamed it to 6 and it worked. There is 1 strange thing, the date of 2011 are displayed as month-day-year instead of day-month-year.

Ger

[Bob Phillips]

i only had 6 sheets but i adjusted "K". The problem was that i named a sheet 01-2011. I renamed it to 6 and it worked. There is 1 strange thing, the date of 2011 are displayed as month-day-year instead of day-month-year.

Sorry, I am not getting that. What date of 2011 are you referring to?

[Ger]

In the example you can see bij name GG the date 1-5-2011.
In sheet 06 the date is 5-1-2011.

Ger

[Bob Phillips]

Dates are such a pain in VBA :banghead:



Sub CreateXRef()
Dim i As Long, j As Long, k As Long
Dim LastCol As Long
Dim LastRow As Long
Dim NextRow As Long
Dim FoundRow As Long
Dim sh As Worksheet

Application.ScreenUpdating = False

Application.DisplayAlerts = False
On Error Resume Next
Worksheets("output").Delete
On Error GoTo 0
Application.DisplayAlerts = True

Set sh = Worksheets.Add(before:=Worksheets(1))
sh.Name = "output"
sh.Range("A2").Value = "Name:"
NextRow = 1

For k = 1 To 6

With Worksheets(Format(k, "00"))

For j = 2 To 8

LastRow = .Cells(.Rows.Count, j).End(xlUp).Row
For i = 3 To LastRow

FoundRow = 0
On Error Resume Next
FoundRow = Application.Match(.Cells(i, j).Value2, sh.Columns("B"), 0)
On Error GoTo 0
If FoundRow = 0 Then

NextRow = NextRow + 1
sh.Cells(NextRow, "B").Value2 = .Cells(i, j).Value2
FoundRow = NextRow
End If

LastCol = sh.Cells(FoundRow, sh.Columns.Count).End(xlToLeft).Column
sh.Cells(FoundRow, LastCol + 1).Value2 = CDate(.Cells(2, j).Value2)
sh.Cells(FoundRow, LastCol + 1).NumberFormat = .Cells(2, j).NumberFormat
Next i
Next j
End With
Next k

Application.ScreenUpdating = True

End Sub
:banghead:

[Ger]

Thanks,

as usual XLD and MDMACKILLOP where very helpfull.
:clap2: :friends:


Ger