Find text in colunn Then count rows with data
 

Hopefully, all the typos are gone and the omissions have been added in. I
did a full test on this one and it listed all of the data correctly. I did
not include the naming of the new workbook nor saving it since you gave no
indication that it would always be the same. You can handle that manually.
One thing to remember is that it will create a new workbook each time it is
run, NOT the same workbook over and over..

Sub countRows()
Dim rc As Long, lr As Long, lr2 As Long
Dim c As Range, NewBk As Workbook, rng As Range
Dim myFolder As String, sh As Worksheet, wb As Workbook
Set NewBk = Workbooks.Add
For Each wb In Application.Workbooks
If wb.Name < NewBk.Name Then
For Each sh In wb.Worksheets
rc = 0
lr = sh.Cells(Rows.Count, 3).End(xlUp).Row
Set c = sh.Cells.Find("Surname", LookIn:=xlValues)
If Not c Is Nothing Then
Set rng = Range("C" & c.Row + 1 & ":C" & lr)
rc = rng.Rows.Count
End If
With NewBk.Sheets(1)
lr2 = NewBk.Sheets(1) _
.Cells(Rows.Count, 1).End(xlUp).Row
If .Range("A2") = "" Then
.Range("A2") = wb.Name
.Range("B2") = sh.Name
.Range("C2") = rc
Else
.Range("A" & lr2 + 1) = wb.Name
.Range("B" & lr2 + 1) = sh.Name
.Range("C" & lr2 + 1) = rc
End If
End With
Next
End If
Next

End Sub


"Diddy" wrote in message
...

Find text in colunn Then count rows with data
 

Hope you get the reply because it has been a couple of days since I logged in
- thank you so much
Diddy

"JLGWhiz" wrote:

Hopefully, all the typos are gone and the omissions have been added in. I
did a full test on this one and it listed all of the data correctly. I did
not include the naming of the new workbook nor saving it since you gave no
indication that it would always be the same. You can handle that manually.
One thing to remember is that it will create a new workbook each time it is
run, NOT the same workbook over and over..

Sub countRows()
Dim rc As Long, lr As Long, lr2 As Long
Dim c As Range, NewBk As Workbook, rng As Range
Dim myFolder As String, sh As Worksheet, wb As Workbook
Set NewBk = Workbooks.Add
For Each wb In Application.Workbooks
If wb.Name < NewBk.Name Then
For Each sh In wb.Worksheets
rc = 0
lr = sh.Cells(Rows.Count, 3).End(xlUp).Row
Set c = sh.Cells.Find("Surname", LookIn:=xlValues)
If Not c Is Nothing Then
Set rng = Range("C" & c.Row + 1 & ":C" & lr)
rc = rng.Rows.Count
End If
With NewBk.Sheets(1)
lr2 = NewBk.Sheets(1) _
.Cells(Rows.Count, 1).End(xlUp).Row
If .Range("A2") = "" Then
.Range("A2") = wb.Name
.Range("B2") = sh.Name
.Range("C2") = rc
Else
.Range("A" & lr2 + 1) = wb.Name
.Range("B" & lr2 + 1) = sh.Name
.Range("C" & lr2 + 1) = rc
End If
End With
Next
End If
Next

End Sub


"Diddy" wrote in message
...