counting the rows that match in my loop

A

andycharger

Hi guys,

Long time no post! Anyway, I got a little poser for you....

My code is taking forever to run. I have a looping statement that ha
about 6 or 7 nested if statements.

Basically, It says the following
[vb]
For rowdates2 = Range("A1").End(xlDown).Row To 2 Step -1

If Cells(rowdates2, "A") = strBranch Then
If Cells(rowdates2, "B") = strRef Then
If Cells(rowdates2, "E") = strPCode Then
If Cells(rowdates2, "I").Value = strRegNo Then
If Cells(rowdates2, "J").Value = strTranDate Then
If Cells(rowdates2, "K").Value = strTranType Then
strCount = strCount + 1

Else
End If

Else
End If
Else
End If

Else
'do nothing
End If

Else
'do nothing
End If
Else
'do nothing

End If

Next
[/vb]



If it gets a match, it increases the counter by 1. (strCount)


What I need it to do instead is if the counter is bigger than 0, d
something. However, I do remember something about FIND in VBA.
How can I get the number of matches (count) back by using the FIN
statement? It would be quicker than using the loop.

Any ideas let me kno
 
T

Tom Ogilvy

strCount = 0
set rng = Columns(1).Find(strBranch)
if not rng is nothing then
sAddr = rng.Address
do
Rowdates2 = rng.row

If Cells(rowdates2, "B") = strRef And _
Cells(rowdates2, "E") = strPCode And _
Cells(rowdates2, "I").Value = strRegNo And _
Cells(rowdates2, "J").Value = strTranDate And _
Cells(rowdates2, "K").Value = strTranType Then
if strcount <> 0 then
'process the rng
' exit Do
else
strCount = strcount + 1
end if
end if
set rng = columns(1).FindNext(rng)
Loop until rng.Address = sAddr
End If
 
A

andycharger

Thanks tim, excellent answer as always!

However, I have changed it slightly. I loop through once exactly as yo
typed the code. However, I then use a different statement.
I say if strCount >1 then use the find method and delete the row.

This works ok but it falls ov er on the .findnext part of your code.

It says "Unable to get the FindNext property of the Range Class"

I guess this is because there may not be another row with that match i
the range.

So how do I change the last couple of lines to exit out if it canno
find another row matching?

Cheers!

And
 
T

Tom Ogilvy

strCount = 0
set rng = Columns(1).Find(strBranch)
if not rng is nothing then
sAddr = rng.Address
do
Rowdates2 = rng.row

If Cells(rowdates2, "B") = strRef And _
Cells(rowdates2, "E") = strPCode And _
Cells(rowdates2, "I").Value = strRegNo And _
Cells(rowdates2, "J").Value = strTranDate And _
Cells(rowdates2, "K").Value = strTranType Then
if strcount <> 0 then
'process the rng
' exit Do
else
strCount = strcount + 1
end if
end if
set rng = columns(1).FindNext(rng)
if rng is nothing then exit do
Loop until rng.Address = sAddr
End If
 
A

andycharger

Thanks again tom, but like I said, I get that error as soon as it get
to the "findnext" line of code.
It says "Unable to get the FindNext property of the Range Class" a
soon as the code is on the SET line.
I tried stepping through the code and this is where it stops.

The IF rng Is Nothing statement does not work because the code fall
over if the findnext is not possible.

I think the check for a findnext needs to be prior to the set rng bu
not sure how.

Any ideas?

Thanks for all your help in this
 
J

Jamie Collins

andycharger wrote ...
My code is taking forever to run. I have a looping statement that has
about 6 or 7 nested if statements.
Click to expand...

You are correct, a loop will be slow. If you need the count, try the
following approach:

This code in a standard module in the workbook containing the data
(assumes the data is on the active sheet. Review the variable
assignments for proper values e.g.

strBranch = "a"
strRef = "a"
etc

to match your data.

' --- code ---
Option Explicit

Sub Test()

Dim strBranch As String
Dim strRef As String
Dim strPCode As String
Dim strRegNo As String
Dim strTranDate As String
Dim strTranType As String

strBranch = "a"
strRef = "a"
strPCode = "a"
strRegNo = "a"
strTranDate = "a"
strTranType = "a"

Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim Target As Excel.Range
Dim Con As Object
Dim rs As Object
Dim strCon As String
Dim strPath As String
Dim strSql1 As String
Dim lngCount As Long

' Amend the following constants to suit
Const FILENAME_XL_TEMP As String = "" & _
"delete_me.xls"
Const TABLE_NAME_NEW As String = "" & _
"MyNewTable"

' Do NOT amend the following constants
Const CONN_STRING_1 As String = "" & _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=<PATH><FILENAME>;" & _
"Extended Properties='Excel 8.0;HDR=NO;IMEX=1'"

' Build connection strings
strPath = ThisWorkbook.Path & _
Application.PathSeparator

strCon = CONN_STRING_1
strCon = Replace(strCon, _
"<PATH>", strPath)
strCon = Replace(strCon, _
"<FILENAME>", FILENAME_XL_TEMP)

' Build sql statement
strSql1 = ""
strSql1 = strSql1 & "SELECT COUNT(*) FROM "
strSql1 = strSql1 & " [" & TABLE_NAME_NEW & "$A1:K65536]"
strSql1 = strSql1 & " WHERE F1='" & strBranch & "'"
strSql1 = strSql1 & " AND F2='" & strRef & "'"
strSql1 = strSql1 & " AND F5='" & strPCode & "'"
strSql1 = strSql1 & " AND F9='" & strRegNo & "'"
strSql1 = strSql1 & " AND F10='" & strTranDate & "'"
strSql1 = strSql1 & " AND F11='" & strTranType & "'"

' Delete old instance of temp workbook
On Error Resume Next
Kill strPath & FILENAME_XL_TEMP
On Error GoTo 0

' Save copy of worksheet to temp workbook
Excel.Application.ScreenUpdating = False
Set ws = ActiveSheet
Set wb = Excel.Application.Workbooks.Add()
With wb
ws.Copy .Worksheets(1)
.Worksheets(1).Name = TABLE_NAME_NEW
.SaveAs strPath & FILENAME_XL_TEMP
.Close
End With
Excel.Application.ScreenUpdating = True

' Open connection to temp workbook
Set Con = CreateObject("ADODB.Connection")
With Con
.ConnectionString = strCon
.Open
Set rs = .Execute(strSql1)
lngCount = rs.Fields(0).Value
.Close
End With

MsgBox CStr(lngCount) & " rows."

End Sub
' --- code ends ---

Jamie.

--
 
J

Jamie Collins

andycharger wrote ...
My code is taking forever to run. I have a looping statement that has
about 6 or 7 nested if statements.
Click to expand...

You are correct, a loop will be slow. If you need the count, try the
following approach:

This code in a standard module in the workbook containing the data
(assumes the data is on the active sheet. Review the variable
assignments for proper values e.g.

strBranch = "a"
strRef = "a"
etc

to match your data.

' --- code ---
Option Explicit

Sub Test()

Dim strBranch As String
Dim strRef As String
Dim strPCode As String
Dim strRegNo As String
Dim strTranDate As String
Dim strTranType As String

strBranch = "a"
strRef = "a"
strPCode = "a"
strRegNo = "a"
strTranDate = "a"
strTranType = "a"

Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim Target As Excel.Range
Dim Con As Object
Dim rs As Object
Dim strCon As String
Dim strPath As String
Dim strSql1 As String
Dim lngCount As Long

' Amend the following constants to suit
Const FILENAME_XL_TEMP As String = "" & _
"delete_me.xls"
Const TABLE_NAME_NEW As String = "" & _
"MyNewTable"

' Do NOT amend the following constants
Const CONN_STRING_1 As String = "" & _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=<PATH><FILENAME>;" & _
"Extended Properties='Excel 8.0;HDR=NO;IMEX=1'"

' Build connection strings
strPath = ThisWorkbook.Path & _
Application.PathSeparator

strCon = CONN_STRING_1
strCon = Replace(strCon, _
"<PATH>", strPath)
strCon = Replace(strCon, _
"<FILENAME>", FILENAME_XL_TEMP)

' Build sql statement
strSql1 = ""
strSql1 = strSql1 & "SELECT COUNT(*) FROM "
strSql1 = strSql1 & " [" & TABLE_NAME_NEW & "$A1:K65536]"
strSql1 = strSql1 & " WHERE F1='" & strBranch & "'"
strSql1 = strSql1 & " AND F2='" & strRef & "'"
strSql1 = strSql1 & " AND F5='" & strPCode & "'"
strSql1 = strSql1 & " AND F9='" & strRegNo & "'"
strSql1 = strSql1 & " AND F10='" & strTranDate & "'"
strSql1 = strSql1 & " AND F11='" & strTranType & "'"

' Delete old instance of temp workbook
On Error Resume Next
Kill strPath & FILENAME_XL_TEMP
On Error GoTo 0

' Save copy of worksheet to temp workbook
Excel.Application.ScreenUpdating = False
Set ws = ActiveSheet
Set wb = Excel.Application.Workbooks.Add()
With wb
ws.Copy .Worksheets(1)
.Worksheets(1).Name = TABLE_NAME_NEW
.SaveAs strPath & FILENAME_XL_TEMP
.Close
End With
Excel.Application.ScreenUpdating = True

' Open connection to temp workbook
Set Con = CreateObject("ADODB.Connection")
With Con
.ConnectionString = strCon
.Open
Set rs = .Execute(strSql1)
lngCount = rs.Fields(0).Value
.Close
End With

MsgBox CStr(lngCount) & " rows."

End Sub
' --- code ends ---

Jamie.

--
 
Top