Filtered counts

  • Thread starter Thread starter Jako
  • Start date Start date
J

Jako

Can anyone please tell me how i can count the number of rows o
worksheet "Raw" that contain the text "Acorn" in column "E" but only i
the cell in column "V" is not empty.

Also i would like to copy the row that meets the above criteria to
new worksheet called "Checked"

TI
 
Thanks for the reply.

Is there a way to do it as a VBA macro / Subroutine?

Also i woould like to then create an Add-in for this and other simila
processes.

Is it the case that they must all be programmed as functions to be abl
to use them as Add-Ins?

Thank
 
Hi
why do you want to do it within VBA? this would probably slower!
 
Don't i have to do it in VBA to create an Add-in that i can share on
numerous computers to people with very basic Excel knowledge?
 
You could loop through the range or use just evaluate the worksheet function:

MsgBox _
ActiveSheet.Evaluate("=SUMPRoDUCT(--(E1:E1000=""Acorn""),--(V1:V1000<>""""))")

(I added the "o" in sumproduct. <vbg>)
 
Depends on what your addin is going to do with it.

If you just want to show it to the user, then you can use the msgbox.

If you're going to do something else with the value,

sub testme
dim myVal as long
myval = _
ActiveSheet.Evaluate("=SUMPRoDUCT(--(E1:E1000=""Acorn""),--(V1:V1000<>""""))")
'do what you want after that
end sub
 
Many thanks that works a treat.

Please could you tell me how i can then use this to check all th
worksheets of any workbooks in a folder called Audit on the C:.
ie C:/Audit.

What i want to do is check each workbook (all worksheet therein) i
this directory using the function you have provided.

TI
 
Open each of the workbooks and then evaluate the function for each worksheet:

Option Explicit
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

'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"
Exit Sub
End If

Application.ScreenUpdating = False

Set RptWks = Workbooks.Add(1).Worksheets(1)
RptWks.Range("a1").Resize(1, 3).Value _
= Array("workbook Name", "worksheet Name", "value")

'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
myVal = _
wks.Evaluate("=SUMPRoDUCT(--(E1:E1000=""Acorn"")," & _
"--(V1:V1000<>""""))")
With RptWks.Cells(oRow, "A")
.Value = tempWkbk.FullName
.Offset(0, 1).Value = "'" & wks.Name
.Offset(0, 2).Value = myVal
End With
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
 
That worked great Dave thanks. I adapted the code as i have change
slightly the layout of the sheets i am checking:

This is the code that i now have:


Option Explicit
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

'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)
RptWks.Range("a1").Resize(1, 3).Value _
= Array("WORKBOOK NAME", "WORKSHEET NAME", "VALUE")

'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
myVal = _
wks.Evaluate("=SUMPRoDUCT(--(G1:G10000=""Topshot Ltd"")," & _
"--(V1:V10000<>""""))")
With RptWks.Cells(oRow, "A")
.Value = tempWkbk.FullName
.Offset(0, 1).Value = "'" & wks.Name
.Offset(0, 2).Value = myVal
End With
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

' **********************************************

Would it be possible to expand it further to accomodate more searc
strings as well as "Acorn".

this is my output after the macro you posted:

WORKBOOK NAME WORKSHEET NAME VALUE
C:\Audits\ClearOrClosedSent1.xls Sheet1 2
C:\Audits\ClearOrClosedSent1.xls Sheet2 0
C:\Audits\ClearOrClosedSent1.xls Sheet3 0
C:\Audits\ClearOrClosedSent.xls Sheet1 3
C:\Audits\ClearOrClosedSent.xls Sheet2 0
C:\Audits\ClearOrClosedSent.xls Sheet3 0

What i would like to do is expand it further and use more strings e.g

"Acorn" , "Caddick" , "Morrison" , "Lantel" etc but could be possibl
15 or more!!

I would like the output as this:

Acorn
WORKBOOK NAME WORKSHEET NAME VALUE
C:\Audits\ClearOrClosedSent1.xls Sheet1 2
C:\Audits\ClearOrClosedSent1.xls Sheet2 0
C:\Audits\ClearOrClosedSent1.xls Sheet3 0
C:\Audits\ClearOrClosedSent.xls Sheet1 3
C:\Audits\ClearOrClosedSent.xls Sheet2 0
C:\Audits\ClearOrClosedSent.xls Sheet3 0
Caddick
WORKBOOK NAME WORKSHEET NAME VALUE
C:\Audits\ClearOrClosedSent1.xls Sheet1 2
C:\Audits\ClearOrClosedSent1.xls Sheet2 0
C:\Audits\ClearOrClosedSent1.xls Sheet3 0
C:\Audits\ClearOrClosedSent.xls Sheet1 3
C:\Audits\ClearOrClosedSent.xls Sheet2 0
C:\Audits\ClearOrClosedSent.xls Sheet3 0
Morrison
WORKBOOK NAME WORKSHEET NAME VALUE
C:\Audits\ClearOrClosedSent1.xls Sheet1 2
C:\Audits\ClearOrClosedSent1.xls Sheet2 0
C:\Audits\ClearOrClosedSent1.xls Sheet3 0
C:\Audits\ClearOrClosedSent.xls Sheet1 3
C:\Audits\ClearOrClosedSent.xls Sheet2 0
C:\Audits\ClearOrClosedSent.xls Sheet3 0
Lantel
WORKBOOK NAME WORKSHEET NAME VALUE
C:\Audits\ClearOrClosedSent1.xls Sheet1 2
C:\Audits\ClearOrClosedSent1.xls Sheet2 0
C:\Audits\ClearOrClosedSent1.xls Sheet3 0
C:\Audits\ClearOrClosedSent.xls Sheet1 3
C:\Audits\ClearOrClosedSent.xls Sheet2 0
C:\Audits\ClearOrClosedSent.xls Sheet3 0

Could you please adapt your code (i have tried but only cocked it u
!!) to accomodate this. Basically i want each to go on the next empt
row.

I think possibly some sort of Array with For Next loops or simila
would be the way but am not knowledgable enough to figure it out.

Please could you insert comments of how to add other search string
like "Lantel" etc and any other changes i would need to make.

I appreciate your efforts and time with your help.

TI
 
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>>
 
FANTASTIC !!

Many thanks that's perfect and far better than what i was asking for a
well.
Thankyou again for all your advice and time
 
You must log in or register to reply here.

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

Filter with criteria! 4
need help on either doing a loop and counting specific values orusing subtotal function 2
Excel 2013 Merge Data 2
array and displaying count 5
Count latest number of continous not-empty cells in a row. 11
Counting rows in a column 5
Convert Advanced filter macro to VBA 2
Counting number of e-mail arrived with specific subject for a day, from Excel 2

Back
Top