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 g
horizontally(Columns) and the array search string results g
vertically(Rows).

Please can anyone help.

TI

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

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/

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/

Thanks for the reply Tom.

I encounter an error on this line

.Range("BB1").PasteSpecial Paste:=xlPasteAll, _
Transpose:=True

What i want is as this:

A B

1 wbook Wsheet
2
3 Red x
4 Blue x
5 Green x
6 Orange x
7 Gold x

TOTAL: xxx

Please note though that there will be more entries than these colour
so i need the total to be in the next empty cell in column B.

Thanks in advanc

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

The code worked fine for me. That would be an indication that you don't
have enough columns to paste the data you have. Excel only has 256
columns.

Not sure why you chose BB1 to paste the data.



--
Regards,
Tom Ogilvy

"Jako " wrote in message
...
Thanks for the reply Tom.

I encounter an error on this line

Range("BB1").PasteSpecial Paste:=xlPasteAll, _
Transpose:=True

What i want is as this:

A B

1 wbook Wsheet
2
3 Red x
4 Blue x
5 Green x
6 Orange x
7 Gold x

TOTAL: xxx

Please note though that there will be more entries than these colours
so i need the total to be in the next empty cell in column B.

Thanks in advance


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

Sorry Tom,

I changed to "BB1" because with extra data i had it ran to "AD1"
so "I1" would have overwritten my data !!

Thanks agai

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

I have retried the code you supplied Tom and i still get Error cod
1004

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

How many rows of data do you have.

--
Regards,
Tom Ogilvy


"Jako " wrote in message
...
I have retried the code you supplied Tom and i still get Error code
1004.


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

I have four rows and the data runs to column BZ.

Thats why i wanted the array heading to go vertically by row

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

AD, BB, now BZ,

In any event, the code ran fine for me. It produced about 7 columns of data
*before* it transposed it.

My question was meant to find out how many rows of data you had before the
transpose - since you said it failed at that point.


I can't guess what you have on your sheet, so there isn't much I can say.

--
Regards,
Tom Ogilvy





"Jako " wrote in message
...
I have four rows and the data runs to column BZ.

Thats why i wanted the array heading to go vertically by row.


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