Or maybe you meant like this:

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 = "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, 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
.Range("A1").CurrentRegion.Copy
.Range("I1").PasteSpecial Paste:=xlPasteAll, _
Transpose:=True
.Columns(1).Resize(, 8).EntireColumn.Delete
.UsedRange.Columns.AutoFit

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/