It was easier to modify Dave Peterson's second set of code:

Option Explicit
Option Base 0
Sub testme01()

Dim myFiles() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim tempWkbk As Workbook
Dim wks As Worksheet
Dim myVal As Long
Dim oRow As Long
Dim RptWks As Worksheet
Dim myWords As Variant
Dim wdCtr As Long
Dim i As Long, lastrw As Long

myWords = Array("Topshot Ltd", "Acorn", "Caddick", "Morrison", "Lantel")

'change to point at the folder to check
myPath = "D:\Folder2\"
If Right(myPath, 1) < "\" Then
myPath = myPath & "\"
End If

myFile = Dir(myPath & "*.xls")
If myFile = "" Then
MsgBox "NO FILES FOUND AT THIS LOCATION !!"
Exit Sub
End If

Application.ScreenUpdating = False

Set RptWks = Workbooks.Add(1).Worksheets(1)
With RptWks
.Range("a1").Resize(1, 4).Value _
= Array("Word", "WORKBOOK NAME", "WORKSHEET NAME", "VALUE")
End With

'get the list of files
fCtr = 0
Do While myFile < ""
fCtr = fCtr + 1
ReDim Preserve myFiles(1 To fCtr)
myFiles(fCtr) = myFile
myFile = Dir()
Loop

If fCtr 0 Then
oRow = 2
For fCtr = LBound(myFiles) To UBound(myFiles)
Application.StatusBar = "Processing: " & myFiles(fCtr)
Set tempWkbk = Workbooks.Open(FileName:=myPath & myFiles(fCtr))
For Each wks In tempWkbk.Worksheets
For wdCtr = LBound(myWords) To UBound(myWords)
myVal = _
wks.Evaluate("=SUMPRoDUCT(--(G1:G10000=""" _
& myWords(wdCtr) & """)," & _
"--(V1:V10000<""""))")
With RptWks.Cells(oRow, "A")
.Value = myWords(wdCtr)
.Offset(0, 1).Value = tempWkbk.FullName
.Offset(0, 2).Value = "'" & wks.Name
.Offset(0, 3).Value = myVal
End With
oRow = oRow + 1
Next wdCtr

Next wks
tempWkbk.Close savechanges:=False
Next fCtr
End If

With RptWks
.UsedRange.Columns.AutoFit
With .Range("a:d")
.Sort key1:=.Columns(1), order1:=xlAscending, header:=xlYes
End With
' .Cells(2, 1).EntireRow.Insert
lastrw = .Cells(Rows.Count, 1).End(xlUp).Row
For i = lastrw To 1 Step -1
If .Cells(i, 1).Value < .Cells(i + 1, 1).Value And _
Not IsEmpty(.Cells(i + 1, 1)) Then
.Cells(i + 1, 1).EntireRow.Insert
.Cells(i + 1, 2).Value = .Cells(i + 2, 1).Value
End If
Next
.Columns(1).Delete
End With

With Application
.ScreenUpdating = True
.StatusBar = False
End With

End Sub

--
Regards,
Tom Ogilvy

"Jako " wrote in message
...
I was given this code by one of the clever, helpful guys on this forum.


Option Explicit


Option Base 0
Sub StatCount()

Dim myFiles() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim tempWkbk As Workbook
Dim wks As Worksheet
Dim myVal As Long
Dim oRow As Long
Dim RptWks As Worksheet
Dim myWords As Variant
Dim wdCtr As Long

myWords = Array("Red", "Blue", "Green", "Orange", "Gold")

'change to point at the folder to check
'myPath = "c:\my documents\excel\test"
myPath = "c:\Audits"
If Right(myPath, 1) < "\" Then
myPath = myPath & "\"
End If

myFile = Dir(myPath & "*.xls")
If myFile = "" Then
MsgBox "NO FILES FOUND AT THIS LOCATION !!"
Exit Sub
End If

Application.ScreenUpdating = False

Set RptWks = Workbooks.Add(1).Worksheets(1)
With RptWks
Range("a1").Resize(1, 2).Value _
= Array("WORKBOOK NAME", "WORKSHEET NAME")

Range("C1").Resize(1, UBound(myWords) - LBound(myWords) + 1).Value _
= myWords
End With

'get the list of files
fCtr = 0
Do While myFile < ""
fCtr = fCtr + 1
ReDim Preserve myFiles(1 To fCtr)
myFiles(fCtr) = myFile
myFile = Dir()
Loop

If fCtr 0 Then
oRow = 2
For fCtr = LBound(myFiles) To UBound(myFiles)
Application.StatusBar = "Processing: " & myFiles(fCtr)
Set tempWkbk = Workbooks.Open(Filename:=myPath & myFiles(fCtr))
For Each wks In tempWkbk.Worksheets
With RptWks.Cells(oRow, "A")
Value = tempWkbk.FullName
Offset(0, 1).Value = "'" & wks.Name
End With
For wdCtr = LBound(myWords) To UBound(myWords)
myVal = _
wks.Evaluate("=SUMPRoDUCT(--(G1:G10000=""" _
& myWords(wdCtr) & """)," & _
"--(G1:G10000<""""))")

RptWks.Cells(oRow, "A").Offset(0, 2 + wdCtr).Value = myVal
Next wdCtr
oRow = oRow + 1
Next wks
tempWkbk.Close savechanges:=False
Next fCtr
End If

With RptWks
UsedRange.Columns.AutoFit
End With

With Application
ScreenUpdating = True
StatusBar = False
End With

End Sub

However i can't restructure it so the workbook names go
horizontally(Columns) and the array search string results go
vertically(Rows).

Please can anyone help.

TIA


---
Message posted from http://www.ExcelForum.com/