Have you thought about laying out the report so that the workbook name and
worksheet name appears only once--and the values for the words you're looking
for go across.
If you think you'd like that layout try this:
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
myWords = Array("Topshot Ltd", "Acorn", "Caddick", "Morrison", "Lantel")
'change to point at the folder to check
myPath = "c:\my documents\excel\test"
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) & """)," & _
"--(V1:V10000<>""""))")
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
And if you really want one line per word per worksheet per workbook, I wouldn't
lay it out quite the way you suggested.
I'd put the word on each row (column A??). By having it on each line, I could
use Data|filter|autofilter. I could do charts and graphs, I could do
data|pivottable much easier.
Here's the second version:
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
myWords = Array("Topshot Ltd", "Acorn", "Caddick", "Morrison", "Lantel")
'change to point at the folder to check
myPath = "c:\my documents\excel\test"
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
End With
With Application
.ScreenUpdating = True
.StatusBar = False
End With
End Sub
(And remember to change the path!)
<<snipped>>
