PDA

View Full Version : [SOLVED] Using Countif formula in vb



spittingfire
10-04-2016, 09:58 AM
Hi All.

I have a simple attached test workbook (test_file.xlsx) that only have a date column.

What I want to do is from a new workbook I want to apply the following formulas using vba
=COUNTIF(A:A,"="&TODAY())
=COUNTIF(A:A,"<="&TODAY()-2)
=COUNTIF(A:A,">"&TODAY())

and return the values in the current workbook in cells

B1
B2
B3


The data sheet will have new data on a daily basis but all I care about is the data in column A.

For simplicity purposes the workbook is located in C:\test_file.xlsx

Will be nice if the vb can perform the calculations while the other workbook is closed but not that important if it's not possible.

Any assistance will be appreciated.

Thanks

Kenneth Hobs
10-04-2016, 11:29 AM
If the date file is open, then the usual reference would suffice.
e.g. =COUNTIF([test_file.xlsx]Sheet1!$A:$A,"="&TODAY())

spittingfire
10-04-2016, 11:41 AM
Thanks Kenneth, that is something that I'm aware of but actually what I would prefer is to have a script of some kind to fetch the sheet and do the calculation and paste the results in B1, B2 and B3 of the new workbook.

Kenneth Hobs
10-04-2016, 12:18 PM
It is a simple matter. Did you need help with that? A recorded macro should get you most of the way there. You can easily record opening the date file or a copy of it to open, and then add the "formula" as a string for the 3 ranges, and then close the date file.

Another method one can do is to use a formula to add all of the date file's data sheet. Then your formula(s) would reference that sheet's column A data.

An even more involved method is to use ADO. Of course then your data would be static.

JKwan
10-04-2016, 12:54 PM
Give your data a header, I called it DATE. Give this a try

Option Explicit
Sub FetchData()
' Need to reference Microsoft ActiveX Data Objects 2.x
Dim stSQLstring As String

Application.ScreenUpdating = False

stSQLstring = "Select Count([Date]) From " & _
"[Sheet1$] Where [Date] = #" & Format(Now, "mm/dd/yyyy") & "#" & _
";"
QueryWorksheet stSQLstring, _
Sheet1.Range("B1"), _
"C:\test\test_file.xlsx"

stSQLstring = "Select Count([Date]) From " & _
"[Sheet1$] Where [Date] <= #" & Format(Now - 2, "mm/dd/yyyy") & "#" & _
";"
QueryWorksheet stSQLstring, _
Sheet1.Range("B2"), _
"C:\test\test_file.xlsx"

stSQLstring = "Select Count([Date]) From " & _
"[Sheet1$] Where [Date] > #" & Format(Now, "mm/dd/yyyy") & "#" & _
";"
QueryWorksheet stSQLstring, _
Sheet1.Range("B3"), _
"C:\test\test_file.xlsx"
Application.ScreenUpdating = True
End Sub
Public Sub QueryWorksheet(szSQL As String, rgStart As Range, wbWorkBook As String)
Dim rsData As ADODB.Recordset
Dim szConnect As String

On Error GoTo ErrHandler
Application.StatusBar = "Retrieving data ....."
szConnect = "Provider = Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & wbWorkBook & ";" & _
"Extended Properties=Excel 12.0;"

Set rsData = New ADODB.Recordset
rsData.Open szSQL, szConnect, adOpenForwardOnly, adLockReadOnly, adCmdText

If Not rsData.EOF Then
rgStart.CopyFromRecordset rsData
Else
MsgBox "There is no records that matches the query !!", vbCritical
End If
rsData.Close
Set rsData = Nothing
Application.StatusBar = False
Exit Sub
ErrHandler:
'an error occured in the SQL-statement
MsgBox "Your query could not be executed, the SQL-statement is incorrect."
Set rsData = Nothing
Application.StatusBar = False
End Sub

JKwan
10-04-2016, 01:10 PM
by the way, if you don't want to put header onto your data, use this

Option Explicit
Sub FetchData()
' Need to reference Microsoft ActiveX Data Objects 2.x
Dim stSQLstring As String

Application.ScreenUpdating = False

stSQLstring = "Select Count([F1]) From " & _
"[Sheet1$] Where [F1] = #" & Format(Now, "mm/dd/yyyy") & "#" & _
";"
QueryWorksheet stSQLstring, _
Sheet1.Range("B1"), _
"C:\test\test_file.xlsx"

stSQLstring = "Select Count([F1]) From " & _
"[Sheet1$] Where [F1] <= #" & Format(Now - 2, "mm/dd/yyyy") & "#" & _
";"
QueryWorksheet stSQLstring, _
Sheet1.Range("B2"), _
"C:\test\test_file.xlsx"

stSQLstring = "Select Count([F1]) From " & _
"[Sheet1$] Where [F1] > #" & Format(Now, "mm/dd/yyyy") & "#" & _
";"
QueryWorksheet stSQLstring, _
Sheet1.Range("B3"), _
"C:\test\test_file.xlsx"
Application.ScreenUpdating = True
End Sub
Public Sub QueryWorksheet(szSQL As String, rgStart As Range, wbWorkBook As String)
Dim rsData As ADODB.Recordset
Dim szConnect As String

On Error GoTo ErrHandler
Application.StatusBar = "Retrieving data ....."
szConnect = "Provider = Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & wbWorkBook & ";" & _
"Extended Properties=""Excel 12.0;HDR=NO;FMT=Delimited"""

Set rsData = New ADODB.Recordset
rsData.Open szSQL, szConnect, adOpenForwardOnly, adLockReadOnly, adCmdText

If Not rsData.EOF Then
rgStart.CopyFromRecordset rsData
Else
MsgBox "There is no records that matches the query !!", vbCritical
End If
rsData.Close
Set rsData = Nothing
Application.StatusBar = False
Exit Sub
ErrHandler:
'an error occured in the SQL-statement
MsgBox "Your query could not be executed, the SQL-statement is incorrect."
Set rsData = Nothing
Application.StatusBar = False
End Sub

Kenneth Hobs
10-04-2016, 01:50 PM
Here is the formula method played from the Date file. Uncomment the Value line if you want data static.

Sub Main()
Dim s As String

Application.EnableEvents = False
Application.DisplayAlerts = False

s = "=COUNTIF('[" & ThisWorkbook.Name & "]Sheet1'!$A:$A,"
With Workbooks.Add
'DoEvents 'Allow time for workbook to open
Range("B1").Formula = s & """=""&TODAY())"
Range("B2").Formula = s & """<=""&TODAY()-2)"
Range("B3").Formula = s & """>""&TODAY())"
'Range("B1:B3").Value = Range("B1:B3").Value 'Make formula result static.
.SaveAs ThisWorkbook.Path & "\spittingfire.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End With
ThisWorkbook.Close

Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub

spittingfire
10-04-2016, 03:26 PM
Thanks to you both Kenneth Hobs and JKwan for your help. Much appreciated. Both methods work well. I can only give one reputation in 24 hours and you both certainly deserve one. I will add the other reputation in 24 hours. Again much appreciated.