Speed up VBA code

MirageSF
MirageSF used Ask the Experts™
on
Hi,

I am using... the following code to scan 52 sheets completely for the number 85099055 and if it finds that number to sum up the 7 values to its right of where it was found on each sheet.

Works great, however once the sheet contains about 20k plus of other values it slows down to a grind, is there a way to speed this up dramatically...  If it helps the Range can be reduced to just B8:B60, G8:G60 AND V8:V60 and the number will not be on every sheet and if it is will just appear once per sheet.  Thanks

Number = 85099055
Total=0
      For Idx = 1 To 52
            With Sheets(Idx).Cells
                Set c = .Find(Number, .Cells(.Rows.Count, .Columns.Count), lookat:=xlWhole)
                If Not c Is Nothing Then Total = Total + WorksheetFunction.Sum(c.Offset(0, 2).Resize(1, 7))
            End With
        Next

Open in new window

Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Top Expert 2016

Commented:
Hi,


pls try
Number = 85099055
Total=0
      For Idx = 1 To 52
            With Sheets(Idx).UsedRange.Cells
                Set c = .Find(Number, .Cells(.Rows.Count, .Columns.Count), lookat:=xlWhole)
                If Not c Is Nothing Then Total = Total + WorksheetFunction.Sum(c.Offset(0, 2).Resize(1, 7))
            End With
        Next

Open in new window

Regards
Fabrice LambertConsulting
Distinguished Expert 2017

Commented:
What about querying your workbook ?
Dim oConn As Object
Dim oRs As Object
Dim strConnect As String
Dim strSQL As String
Dim ws As Excel.Worksheet

strConnect = vbNullString
strConnect = strConnect & "Provider=Microsoft.ACE.OLEDB.12.0;"
strConnect = strConnect & "Data Source="ThisWorkbook.FullName & ";"
strConnect = strConnect & "Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"";"

Set oConn = CreateObject("ADODB.Connection")

For Each ws In ThisWorkbook.Worksheets
	strSQL = vbNullString
	    '// F1 = column A
		'// F2 = column B ect .. and so on
	strSQL = strSQL & "SELECT F2, F3, F4, F5, F6, F7, F8 ......" & vbcrlf
	strSQL = strSQL & "FROM [" & ws.Name & "$]" & vbcrlf
	strSQL = strSQL & "WHERE F2 = ""85099055""" & vbcrlf    '// column B
	strSQL = strSQL & "   OR F7 = ""85099055""" & vbcrlf    '// column G
	strSQL = strSQL & "   OR F22 = ""85099055"";"   '// column V
	Set oRs = CreateObject("ADODB.Recordset")
	oRs.Open strSQL, oConn
	If Not(oRs.BOF and oRs.EOF) Then
	    '// recordset isn't empty, do something with datas
	End If
	oRs.Close
	Set Ors = Nothing
Next
oConn.Close
Set oConn = Nothing

Open in new window

Notes:
Your workbook will need to be up to date for this to work as expected, so you might need to save it 1st.
Top Expert 2016

Commented:
then try
Number = 85099055
Total=0
      For Idx = 1 To 52
            With Sheets(Idx).Range("B8:B60,G8:G60,V8:V60")
                Set c = .Find(Number, .Cells(.Rows.Count, .Columns.Count), lookat:=xlWhole)
                If Not c Is Nothing Then Total = Total + WorksheetFunction.Sum(c.Offset(0, 2).Resize(1, 7))
            End With
        Next

Open in new window

EDIT Corrected code

Author

Commented:
Rgonzo would that be faster than your other code?  I see u uses usedrange in first one anyway to combine to make it even faster as not all those ranges have numbers, also once it finds number it can leave that particular sheet and move on rather than checking entire ranges regardless cheers
Top Expert 2016
Commented:
if your number is a value then try
Number = 85099055
Total=0
      For Idx = 1 To 52
            With Sheets(Idx).Range("B8:B60,G8:G60,V8:V60").SpecialCells(xlCellTypeConstants, 1) ' replace xlCellTypeConstants with xlCellTypeFormulas if formula
                Set c = .Find(Number, .Cells(.Rows.Count, .Columns.Count), lookat:=xlWhole) ' search for the first element with Number 
                If Not c Is Nothing Then Total = Total + WorksheetFunction.Sum(c.Offset(0, 2).Resize(1, 7))
            End With
        Next

Open in new window

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial