Optimize VBA code

[Johnatha]

Hello!

I have this VBA code that works well, but for a small amount of records. I have to search over 130,000 records, and this VBA code currently takes around 10 minutes to search 20,000 records, so it crashes when trying the entire thing.


Sub atest()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim LR As Long, i As Long, r As Range
Dim wb As Workbook
LR = Range("D" & Rows.Count).End(xlUp).Row
For i = 1 To LR
If Range("D" & i).Value = 23 Then
If r Is Nothing Then
Set r = Union(Range("A" & i).Resize(1, 4), Range("E" & i))
Else
Set r = Union(r, Range("A" & i).Resize(1, 4), Range("E" & i))
End If
End If
Next i
If Not r Is Nothing Then
Set wb = Workbooks.Add(xlWBATWorksheet)
r.Copy Destination:=wb.Sheets(1).Range("A1")
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


Basically, this code just searches column D for a specific value, then copies over columns A:E for rows that meet the criteria. Any help would be great!!

Thanks.

[SamT]

Try this

Sub SamT_Test()
Dim FirstRow As Range
Dim LastRow As Range
Dim wb As Workbook

With Sheets("Sheet1")
.UsedRange.Sort Key1:=.Range("D"), Header:=xlGuess

'Using previous and next in case 23 sorts to first or last rows.
Set FirstRow = Range("D:D").Find("23", .Cells(Rows.Count, 5).End(xlUp), , , , xlNext)
If FirstRow Is Nothing Then Exit Sub
Set LastRow = Range("D:D").Find(23, .Range("D1"), , , , xlPrevious)
.Range("A" & CStr(FirstRow.Row) & ":E" & CStr(LastRow.Row)).Copy
End With

Set wb = Workbooks.Add(xlWBATWorksheet)
wb.Sheets(1).Range("A1").PasteSpecial (xlPasteAll)

End Sub

[snb]

Use autofilter or advancedfilter.

[Johnatha]

Hey SamT,

Tried your code and I can't seem to get it to run... Getting an error. Any thoughts?

Thanks :)

[SamT]

What error? Where?

First put "Option Explicit" at the top of the code page, then run Debug + Compile. Fix any errors found that way. Repeat.

Then Step thru the code by placing the cursor inside the Sub and pressing F8 repeatedly.

Which line of code is yellow when the error occurs.



snb is saying (partly) that if you manually set up Data AutoFiltering, you can hand select which value you want to copy (23, 42, 99, etc,) then this macro from the Excel menus >> Macros


Sub snbBySamT_Test()
Dim wb As Workbook
Set wb = Workbooks.Add(xlWBATWorksheet)

Sheets("Sheet1").Range("A:E").SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Cells(1)
End Sub

To manually use Data AdvancedFilter, you would have to first manually create a new workbook to copy into.

We can write a routine (Macro) that would use AdvancedFilter and run everytime you selected a different cell in Column D. It would copy the rows with the selected value. If we get Sub SamT_Test fixed, we can do the same with it.

If you look in the help files at the Workbook and Worksheet objects, any of the Events listed can be used to trigger a routine. If you have Excel >=2007, you have to go online, (from what I understand. Which ain't all that much.)

[mancubus]

i would do it like snb, ie, use autofilter.



Sub atest()

With Worksheets("Sheet1") 'change worksheet name to suit
.AutoFilterMode = False 'remove previous filters, if any
.Cells(1).AutoFilter Field:=4, Criteria1:=23
If .AutoFilter.Range.Rows.Count > 1 Then 'test if there is at least one row that meets the criteria
.UsedRange.Columns(1).Offset(1).Resize(, 5).SpecialCells(12).Copy 'first 5 columns of all visible rows other than header row
Workbooks.Add(xlWBATWorksheet).Sheets(1).Cells(1).PasteSpecial
End If
.AutoFilterMode = False
End With

End Sub

[Johnatha]

This line ".UsedRange.Sort Key1:=.Range("D"), Header:=xlGuess" gives me the error "Run-time error '1004' Application-defined or object-defined error".

Btw- great tips these are all really helping me out!

Thanks for your help!!

[Johnatha]

Question- how could I incorporate "Union(Range("A" & i).Resize(1, 3), Range("D" & i).Resize(1, 2))" (which allows me to copy the first 3 columns, and another column of my choice + the one beside it)?

I need this function because I will be searching different columns throughout the sheet.

Thanks!

[SamT]

In re Runtime error; Try Range("D:D")
Anybody else? Not really my strong suite.

I'll be back about 6pm, my time

[Krishna Kumar]

You could try something like this code in a new workbook


Option Explicit

Sub kTest()

Dim objConn As Object, objRset As Object
Dim i As Long, xProp As String

Const adOpenstatic = 3
Const adLockOptimistic = 3

Const SourceFileName = "C:\Test\Test.xlsx" 'adjust

Const SheetName As String = "Sheet1" 'adjust
Const ColumnHeader As String = "Field4" 'adjust
Const Criteria As Long = 23 'adjust

Select Case UCase(Right(SourceFileName, 1))
Case "X": xProp = "Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";"
Case "B": xProp = "Extended Properties=""Excel 12.0;HDR=YES"";"
Case "M": xProp = "Extended Properties=""Excel 12.0 Macro;HDR=YES"";"
Case Else
GoTo Xit
End Select

Set objConn = CreateObject("ADODB.Connection")
Set objRset = CreateObject("ADODB.Recordset")

objConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFileName & ";" & vbLf & xProp

objRset.Open "Select * FROM [" & SheetName & "$] Where [" & ColumnHeader & "] = " & Criteria, _
objConn, adOpenstatic, adLockOptimistic

If objRset.RecordCount Then
Sheet1.Range("a2").CopyFromRecordset objRset
For i = 1 To objRset.fields.Count
Sheet1.Cells(1, i).Value = objRset.fields(i - 1).Name
Next
End If

Xit:
End Sub

[mancubus]

pls dont pm and post your questions here.



Sub btest()

With Worksheets("Sheet1")
.AutoFilterMode = False
.Cells(1).AutoFilter Field:=4, Criteria1:=23
If .AutoFilter.Range.Rows.Count > 1 Then
.UsedRange.Columns(9).Offset(1).SpecialCells(12).Copy Workbooks.Add(xlWBATWorksheet).Sheets(1).Cells(1) 'Cells(1) is A1
.UsedRange.Columns(1).Offset(1).Resize(, 3).SpecialCells(12).Copy ActiveWorkbook.Sheets(1).Cells(2) 'Cells(2) is B1
End If
.AutoFilterMode = False
End With

End Sub