Optimising Autofilter macro

[xluser2007]

Hi All,

Today a colleague asked me to help write a macro to copy and paste specific data. the simple rule was that each worksheet in the "target" workbook (where data was to be pasted, had a worksheet with a data varaible name e.g. "N95", "N08" etc which were codes.

These worksheet names i.e. codes, were the key variables used to filter the required data and then copying it and pasting it in the original worksheet.

the following macro works, quite quickly only 2-5 seconds for the entire workbook, but I;m sure it could be coded better:

[vba]Option Explicit

Sub test()

Call copyPasteV("C:\KeySourcedata_Workbook.xls", "Worksheet_keydata_tocopy", "data_AAL")

End Sub

Sub copyPasteV(strSourcewbkname As String, strSourcewkshtname As String, strdatarng As String)

Dim wbksourcedata As Excel.Workbook
Dim wksht As Excel.Worksheet
Dim starttime As Double

starttime = Timer

Application.ScreenUpdating = False

Set wbksourcedata = Workbooks.Open(strSourcewbkname, UpdateLinks:=0)

On Error Resume Next

For Each wksht In ThisWorkbook.Worksheets

wbksourcedata.Activate
Worksheets(strSourcewkshtname).Activate

' Filter the named range in the relevant worksheet that we will open
wbksourcedata.Worksheets(strSourcewkshtname).Range(strdatarng).AutoFilter

Range("B2").Select


Range("B2").Select
Selection.AutoFilter Field:=2, Criteria1:=wksht.Name
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Offset(1, 0).Copy

ThisWorkbook.Activate
Worksheets(wksht.Name).Select
Range("B5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
wbksourcedata.Activate
Worksheets(2).Activate
Application.CutCopyMode = False
Range("A2").Select
wbksourcedata.Worksheets(strSourcewkshtname).Range(strdatarng).AutoFilter
Range("A2").Select


Next wksht

On Error GoTo 0

Set wbksourcedata = Nothing

Application.ScreenUpdating = True


MsgBox "macro took " & (Timer - starttime) & " seconds to finish"

End Sub[/vba]

Any ideas how to improve the syntax etc to only keep the essential elements VBAXers?

Also what sort of key error-handling could I employ going forward?

Any feedback and suggestions appreciated.

[Bob Phillips]

I am having a little difficulty envisaging the data. Can you post some sample workbooks, or at leat tell us what is in each, and some sample data.

[georgiboy]

Try and avoid selecting for example use...

ExampleWorkbook.Sheets("Examlple").Range("A1").Do somethiing else

rather than

ExampleWorkbook.Activate
Sheets("Example").Select
Range("A1").Select
Selection.Do something else

Selecting things slows code down also it causes screen flashing (updating). If you refered to everything without select/activate you would not need to use...

Application.ScreenUpdating = False/True etc...

Hope this helps

[xluser2007]

Hi Bob,

Thanks for your interest.

I've just got home now, so am away from my work computer.

But here is a dummied version (all dummy data values) of the 2 workbooks required to run the macro.

The key is that there is target data workbook ("Sample_target_data_tables.xls") containing 2 key data tables in worksheets named "keydata_tocopy_v1" and "keydata_tocopy_v2".

There is a target paste workbook ("Paste_data_tables_thiswkbook.xls") from which to run the macro to Open the above target workbook and paste data in the relevant worksheets "N01","X56", "N60".

they key is to when the target workbook is opened by the macro, the user must pass through the target data tables to copy data from. Then using the name of the worksheets e.g. "N01", you need to filter the selected table by the "Codes" category (in column B) and paste the entire filtered cells in the worksheet starting in B4 (just underneath the yellow highlighted cell).

Please note that I do no real error-handling or trapping (e.g. checking if the workboook exists, or if it's open, or whether the worksheet filter category "X56" for example is actually a category in "Codes", if it isn;t then to skip this worksheet etc).

Essentially I would like to the way experts like yourself and others do here and be able to write more slicker robust code.

Please let me know if you'd like me to clarify further.

regards,

[xluser2007]

Here is the Sample_target_data_tables.xls workbook.

[Bob Phillips]

Sorry, but that is just adding to the confusion.

You seem to have just pasted the 'target paste' workbook, but then I read the rest as if this were the 'target data' workbook. You refer This is exactly the dilemma I saw in the code.

I have had a shot, but I am not confident without seeing the data workbook, or knowing what data_AAL is/refers to.

[vba]

Sub test()

On Error GoTo test_error
Call copyPasteV("C:\KeySourcedata_Workbook.xls", "Worksheet_keydata_tocopy", "data_AAL")
Exit Sub

test_error:
MsgBox "Error: " & Err.Number & " " & Err.Description
End Sub

Sub copyPasteV(strSourcewbkname As String, strSourcewkshtname As String, strdatarng As String)
Dim wbksourcedata As Workbook
Dim wksht As Worksheet
Dim rng As Range
Dim starttime As Double
Dim NextRow As Long

starttime = Timer

Application.ScreenUpdating = False

On Error Resume Next
Set wbksourcedata = Workbooks(Right$(strSourcewbkname, Len(strSourcewbkname) - InStrRev(strSourcewbkname, "\")))
On Error GoTo 0
If wbksourcedata Is Nothing Then

If Dir(strSourcewbkname, vbNormal) = "" Then

MsgBox "Target workbook not found"
Exit Sub
End If

Set wbksourcedata = Workbooks.Open(strSourcewbkname, UpdateLinks:=0)
End If

For Each wksht In wbksourcedata.Worksheets

With ThisWorkbook.Worksheets(strSourcewkshtname)

' Filter the named range in the relevant worksheet that we will open
.Range(strdatarng).AutoFilter

.Range(strdatarng).AutoFilter Field:=1, Criteria1:=wksht.Name
On Error Resume Next
Set rng = .Range(strdatarng).SpecialCells(xlCellTypeVisible).Offset(1, 0)
On Error GoTo 0
If Not rng Is Nothing Then

If wksht.Range("B3").Value = "" Then

NextRow = 3
Else

NextRow = wksht.Range("B3").End(xlDown).Row
End If
rng.EntireRow.Copy wksht.Range("A" & NextRow)
End If

.Range(strdatarng).AutoFilter
End With
Next wksht

On Error GoTo 0

Set wbksourcedata = Nothing

Application.ScreenUpdating = True

MsgBox "macro took " & (Timer - starttime) & " seconds to finish"

End Sub
[/vba]

[xluser2007]

Sorry, but that is just adding to the confusion.

You seem to have just pasted the 'target paste' workbook, but then I read the rest as if this were the 'target data' workbook. You refer This is exactly the dilemma I saw in the code.

I have had a shot, but I am not confident without seeing the data workbook, or knowing what data_AAL is/refers to.

[vba]

Sub test()

On Error GoTo test_error
Call copyPasteV("C:\KeySourcedata_Workbook.xls", "Worksheet_keydata_tocopy", "data_AAL")
Exit Sub

test_error:
MsgBox "Error: " & Err.Number & " " & Err.Description
End Sub

Sub copyPasteV(strSourcewbkname As String, strSourcewkshtname As String, strdatarng As String)
Dim wbksourcedata As Workbook
Dim wksht As Worksheet
Dim rng As Range
Dim starttime As Double
Dim NextRow As Long

starttime = Timer

Application.ScreenUpdating = False

On Error Resume Next
Set wbksourcedata = Workbooks(Right$(strSourcewbkname, Len(strSourcewbkname) - InStrRev(strSourcewbkname, "\")))
On Error GoTo 0
If wbksourcedata Is Nothing Then

If Dir(strSourcewbkname, vbNormal) = "" Then

MsgBox "Target workbook not found"
Exit Sub
End If

Set wbksourcedata = Workbooks.Open(strSourcewbkname, UpdateLinks:=0)
End If

For Each wksht In wbksourcedata.Worksheets

With ThisWorkbook.Worksheets(strSourcewkshtname)

' Filter the named range in the relevant worksheet that we will open
.Range(strdatarng).AutoFilter

.Range(strdatarng).AutoFilter Field:=1, Criteria1:=wksht.Name
On Error Resume Next
Set rng = .Range(strdatarng).SpecialCells(xlCellTypeVisible).Offset(1, 0)
On Error GoTo 0
If Not rng Is Nothing Then

If wksht.Range("B3").Value = "" Then

NextRow = 3
Else

NextRow = wksht.Range("B3").End(xlDown).Row
End If
rng.EntireRow.Copy wksht.Range("A" & NextRow)
End If

.Range(strdatarng).AutoFilter
End With
Next wksht

On Error GoTo 0

Set wbksourcedata = Nothing

Application.ScreenUpdating = True

MsgBox "macro took " & (Timer - starttime) & " seconds to finish"

End Sub
[/vba]

Bob,

First off, my apologies for causing confusion.

I got home quite late from work and wanted to knock together dummy example workbooks for you, but didn't realise that it ended up being more confusing than it should have.

Secondly, given my poor explanation, you have provided some fantastic code, and I can really see how experts approach the relevant error handling involved in such problems.

In order to better explain, I will still keep the same names for the workbooks as per posts #4, #5, but will try to explain step-by-step.

1. Open up Paste_data_tables_thiswkbook.xls. This the workbook in which we are going to run the macro from, and we want the macro to open up and paste all relevant data into the worksheets in this workbook. This has a set of worksheets e.g. "N01", "X56" etc.

2. Paste your code into a module in Paste_data_tables_thiswkbook.xls. If both workbooks are stored in C:\VBAX\ for example, then running the code from Paste_data_tables_thiswkbook.xls will look like this:
[VBA]Sub test()

On Error GoTo test_error
Call copyPasteV("C:\VBAX\Sample_target_data_tables.xls", "keydata_tocopy_v1", "datatocopyv1")
Exit Sub

test_error:
MsgBox "Error: " & Err.Number & " " & Err.Description
End Sub[/VBA]i.e. the macro should open up C:\VBAX\Sample_target_data_tables.xls (the workbook containing the relevant data tables from which we want to copy filtered data from), and should filter column B in the worksheet "keydata_tocopy_v1" in C:\VBAX\Sample_target_data_tables.xls, with the criteria being the worksheet name in "Paste_data_tables_thiswkbook.xls" e.g. filtering column B in "keydata_tocopy_v1" by "N01" for example.

3. Once we have the filtered data from C:\VBAX\Sample_target_data_tables.xls from worksheet "keydata_tocopy_v1", based on the criteria "N01", we want to copy it and paste it in "Paste_data_tables_thiswkbook.xls", sheet "N01" starting at B4.

4. Once this is pasted we loop through to the next worksheet in "Paste_data_tables_thiswkbook.xls" i.e "X56" and then filter C:\VBAX\Sample_target_data_tables.xls worksheet "keydata_tocopy_v1" column B by criteria "X56" and repeat the above steps.

Does this help clarify the problem and the process required?

Again, I apologise for causing confusion. Your code almost does this, I tried tinkering with it, but couldn't quite get it to work out exactly (having said this I've learnt a lot from it already! ).

I know that any features that didn't work were lost in my translation.

I have tried modifying as below, if you could please help me to complete it to do the above, I would appreciate it.

[VBA]Option Explicit

Sub test()

On Error GoTo test_error
Call copyPasteV("C:\Documents and Settings\Vijay\Desktop\Excel\VBAX\XLD\Sample_target_data_tables.xls", "keydata_tocopy_v1", "datatocopyv1")
Exit Sub

test_error:
MsgBox "Error: " & Err.Number & " " & Err.Description
End Sub

Sub copyPasteV(strSourcewbkname As String, strSourcewkshtname As String, strdatarng As String)
Dim wbksourcedata As Workbook
Dim wksht As Worksheet
Dim rng As Range
Dim starttime As Double
Dim NextRow As Long

starttime = Timer

Application.ScreenUpdating = False

On Error Resume Next
Set wbksourcedata = Workbooks(Right$(strSourcewbkname, Len(strSourcewbkname) - InStrRev(strSourcewbkname, "\")))
On Error GoTo 0
If wbksourcedata Is Nothing Then

If Dir(strSourcewbkname, vbNormal) = "" Then

MsgBox "Target workbook not found"
Exit Sub
End If

Set wbksourcedata = Workbooks.Open(strSourcewbkname, UpdateLinks:=0)
End If

For Each wksht In ThisWorkbook.Worksheets

With wbksourcedata.Worksheets(strSourcewkshtname)

' Filter the named range in the relevant worksheet that we will open
.Range(strdatarng).AutoFilter

.Range(strdatarng).AutoFilter Field:=2, Criteria1:=wksht.Name
On Error Resume Next
Set rng = .Range(strdatarng).SpecialCells(xlCellTypeVisible).Offset(1, 0)
On Error GoTo 0
If Not rng Is Nothing Then

If .Range("B3").Value = "" Then

NextRow = 3
Else

NextRow = .Range("B3").End(xlDown).Row
End If
rng.EntireRow.Copy wksht.Range("A" & NextRow)
End If

.Range(strdatarng).AutoFilter
End With
Next wksht

On Error GoTo 0

Set wbksourcedata = Nothing

Application.ScreenUpdating = True

MsgBox "macro took " & (Timer - starttime) & " seconds to finish"

End Sub[/VBA]

Thanks a ton for your help Bob.

[xluser2007]

Hi Bob,

Sorry to bother again.

With a fresher mind, I've had a go at editing your awesome code for the exact purposes.

Basically, I've got the following code pasted in "C:\VBAX\Sample_target_data_tables\Sample_target_data_tables.xls"

[vba]Option Explicit

Sub test()

On Error GoTo test_error
Call copyPasteV("C:\VBAX\Sample_target_data_tables\Sample_target_data_tables.xls ", "keydata_tocopy_v1", "datatocopyv1")
Exit Sub

test_error:
MsgBox "Error: " & Err.Number & " " & Err.Description
End Sub

Sub copyPasteV(strSourcewbkname As String, strSourcewkshtname As String, strdatarng As String)
Dim wbksourcedata As Workbook
Dim wksht As Worksheet
Dim rng As Range
Dim starttime As Double
Dim NextRow As Long

starttime = Timer

' Application.ScreenUpdating = False

On Error Resume Next
Set wbksourcedata = Workbooks(Right$(strSourcewbkname, Len(strSourcewbkname) - InStrRev(strSourcewbkname, "\")))
On Error GoTo 0
If wbksourcedata Is Nothing Then

If Dir(strSourcewbkname, vbNormal) = "" Then

MsgBox "Target workbook not found"
Exit Sub
End If

Set wbksourcedata = Workbooks.Open(strSourcewbkname, UpdateLinks:=0)
End If

For Each wksht In ThisWorkbook.Worksheets

With wbksourcedata.Worksheets(strSourcewkshtname)

' Filter the named range in the relevant worksheet that we will open
.Range(strdatarng).AutoFilter

.Range(strdatarng).AutoFilter Field:=2, Criteria1:=wksht.Name
On Error Resume Next
Set rng = .Range(strdatarng).SpecialCells(xlCellTypeVisible).Offset(1, 0)
On Error GoTo 0

If Not rng Is Nothing Then

rng.Copy wksht.Range("B4")

' rng.EntireRow.Copy wksht.Range("B4")

End If

.Range(strdatarng).AutoFilter

End With

Next wksht

On Error GoTo 0

Set wbksourcedata = Nothing

Application.ScreenUpdating = True

MsgBox "macro took " & (Timer - starttime) & " seconds to finish"

End Sub[/vba]
This is almost there, onlt one problem. If the worksheet you are looping through, say X56, is not a code that is availible in the filtering criteria i.e. in the line:

[vba].Range(strdatarng).AutoFilter Field:=2, Criteria1:=wksht.Name[/vba]
Then when we have this part of the code:

[vba]Set rng = .Range(strdatarng).SpecialCells(xlCellTypeVisible).Offset(1, 0)
On Error GoTo 0

If Not rng Is Nothing Then

rng.Copy wksht.Range("B4")[/vba]
It ends up copying the first line of the "datatocopyv1" named range i.e. data table, and pasting it in "X56" starting at B4, when it should paste nothing.

Could you please advise on how to handle for this.

I'm sure that this is becasue I've tried to play with your code and removed some feature, but this almost works pending this adjustment.

Any help sincerely appreciated.

P.S.

Try and avoid selecting for example use...

ExampleWorkbook.Sheets("Examlple").Range("A1").Do somethiing else

rather than

ExampleWorkbook.Activate
Sheets("Example").Select
Range("A1").Select
Selection.Do something else

Selecting things slows code down also it causes screen flashing (updating). If you refered to everything without select/activate you would not need to use...

Application.ScreenUpdating = False/True etc...

Hope this helps

georgiboy, I didn't see your post last night. Thanks for your insights.

I honestly tried to activate stuff in a single line rather than selecting/ re-selcting or reactivating, but found that it kept crashing if I kept doing that. I'll try cleaning up my old code and see how it goes again using your optimising suggestions as well.