Please help restructure this code

J

Jako

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
 
T

Tom Ogilvy

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
 
T

Tom Ogilvy

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
 
J

Jako

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
 
T

Tom Ogilvy

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.
 
J

Jako

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
 
J

Jako

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

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

Tom Ogilvy

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.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Batch Processing Macro 9
placing limits on ubound, and lbound 1
A Dave Peterson macro 3
Followup to Dave Peterson search routine from 4/15/08 0
Copy item from Outlook to folder via Excel 12
help with merging worksheets 3
Get data reference to last row 5
NEED HELP!!!! 1

Top