excel macro to filter spreadsheet

CC10
CC10 used Ask the Experts™
on
there are 3 worksheets in the workbook. I would like to filter the spreadsheets so that the rows with 0400 and 1600 times (column B) are copied into seperate spreadsheets. i.e. a total of 6 new spreadsheets.
TEST2.xlsx
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Most Valuable Expert 2011
Awarded 2010

Commented:
Hello,

you could build a pivot table for each sheet, showing "Date GMT" and "GMT" in the row labels and the other columns in the Values area. Then click on a 4:00 time value in the pivot table, hold down Ctrl and click on a 16:00 time value. Righ-click and select Filter > "Keep only selected items".

See attached for the above applied to the EUR sheet, in a new sheet called EUR Filtered.

cheers, teylyn
Copy-of-TEST2.xlsx

Author

Commented:
Teylyn, thanks for that. It works but it is not what I need.

I need to build up seperate databases for each currency but only for the times 0400 and 1600. So each time the macro runs, it should copy the latest data into the relevant spreadsheet. i.e. EUR0400 and EUR1600.

Thanks
Most Valuable Expert 2011
Awarded 2010

Commented:
You can set the filter to include just one value, i.e. either 4:00 or 16:00. The pivot table can be set up with dynamic ranges as the source. The sheets with the pivot tables can be set up to automatically refresh when activated. If you want to pursue this avenue, I can provide the necessary tools.

This will be much more efficient, i.e. faster, than any VBA solution.

Is there a particular reason you need a macro that is slower than a pivot table? It might help if you could describe the bigger picture that explains the VBA requirement.

cheers, teylyn
CompTIA Network+

Prepare for the CompTIA Network+ exam by learning how to troubleshoot, configure, and manage both wired and wireless networks.

Author

Commented:
Take the EUR as the example:

I have a macro that downloads the data through a DDE link into the Test2 spreadsheet. I only need the 0400 and 1600 data. Once I have those I can copy the latest rows into another spreadsheet which then calculates various studies for a trading system. It would be nice to have this automated so that I have one macro that:
1. downloads the main data
2. filters the 0400 and 1600 rows
3. copies them into another spreadsheet (EUR 0400)
4. copies again from EUR0400 to EURCalc
5. runs calculations
6. runs reports

I already have points 1&5&6 and I suppose point 3 could be omiitted but I am not an expert on VB and can only build step by step.  Does that make sense?
Most Valuable Expert 2011
Awarded 2010

Commented:
CC10, I'm about to turn in for the night and will be offline for a few days, but I've asked other experts to come have a look. I'm certain you will get a working solution very soon.

cheers, teylyn

Author

Commented:
thats very kind. Thanks.
Top Expert 2014

Commented:
This code copies the 04:00 and 16:00 rows to new worksheets.
Option Explicit

Public Sub Move400Data()
  Dim wksThing As Worksheet
  Dim intReply As VbMsgBoxResult
  Dim boolFound As Boolean
  Dim colNames As New Collection
  Dim vItem As Variant
  Dim rngFiltered As Range
  Dim rngCriteria As Range
  boolFound = False
  For Each wksThing In ActiveWorkbook.Worksheets
    If wksThing.Name Like "*0400*" Then
      colNames.Add wksThing.Name
      boolFound = True
    End If
  Next
  If boolFound Then
    intReply = MsgBox("Destination worksheets found.  Ok to overwrite?", vbOKCancel, "Overwrite prompt")
    If intReply = vbCancel Then
      Exit Sub
    Else
      'remove existing destination worksheets
      For Each vItem In colNames
        ActiveWorkbook.Worksheets(CStr(vItem)).Delete
      Next
    End If
  End If
  Set colNames = New Collection
  For Each wksThing In ActiveWorkbook.Worksheets
    colNames.Add wksThing.Name
  Next
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.Calculation = xlCalculationManual
  
  'create destination worksheets
  For Each vItem In colNames
    Set wksThing = ActiveWorkbook.Worksheets.Add
    wksThing.Name = vItem & "0400"
  Next
  'create criteria sheet/range
  Set wksThing = ActiveWorkbook.Worksheets.Add()
  wksThing.Visible = xlSheetHidden
  Set rngCriteria = wksThing.Range("A1")
  rngCriteria.Value = "GMT"
  rngCriteria.Offset(1).Formula = "=time(4,0,0)"
  rngCriteria.Offset(2).Formula = "=time(16,0,0)"
  Set rngCriteria = wksThing.Range(rngCriteria, rngCriteria.End(xlDown))
  
  'move data
  For Each vItem In colNames
    Set wksThing = ActiveWorkbook.Worksheets(vItem)
    wksThing.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, rngCriteria, Worksheets(wksThing.Name & "0400").Range("A1")
  Next
  
  'remove criteria worksheet
  rngCriteria.Worksheet.Delete
  
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  Application.Calculation = xlCalculationAutomatic
End Sub

Open in new window

Author

Commented:


I get a debug message on the following line:
wksThing.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, rngCriteria, Worksheets(wksThing.Name & "0400").Range("A1")

Also it opens up 4 new worksheets but they are blank. Maybe it should be 04:00 rather than 0400?

I have included the workbook.

thanks,
Chris
Copy-of-Copy-of-TEST2-1.xlsm
Top Expert 2014
Commented:
>>Maybe it should be 04:00 rather than 0400?
No.  I used the destination worksheet name you supplied in your earlier comment.  If you would prefer a different name, the code can be changed to create different target worksheet names.


I've tweaked the code to ignore any worksheets that include "filtered" in the name or are default sheet names below.  The problem happened after you renamed one of the worksheets.  The code assumes that the workbook contains worksheets that were in your question post or that were the result of running the code.

Option Explicit

Public Sub Move400Data()
  Dim wksThing As Worksheet
  Dim intReply As VbMsgBoxResult
  Dim boolFound As Boolean
  Dim colNames As New Collection
  Dim vItem As Variant
  Dim rngFiltered As Range
  Dim rngCriteria As Range
  boolFound = False
  For Each wksThing In ActiveWorkbook.Worksheets
    If wksThing.Name Like "*0400*" Then
      colNames.Add wksThing.Name
      boolFound = True
    End If
  Next
  If boolFound Then
    intReply = MsgBox("Destination worksheets found.  Ok to overwrite?", vbOKCancel, "Overwrite prompt")
    If intReply = vbCancel Then
      Exit Sub
    Else
      'remove existing destination worksheets
      Application.DisplayAlerts = False
      For Each vItem In colNames
        ActiveWorkbook.Worksheets(CStr(vItem)).Delete
      Next
    End If
  End If
  Set colNames = New Collection
  For Each wksThing In ActiveWorkbook.Worksheets
    If (wksThing.Name Like "*filtered*") Or (wksThing.Name Like "Sheet#*") Then
      'ignore non-currency worksheets
    Else
      colNames.Add wksThing.Name
    End If
  Next
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.Calculation = xlCalculationManual
  
  'create destination worksheets
  For Each vItem In colNames
    Set wksThing = ActiveWorkbook.Worksheets.Add
    wksThing.Name = vItem & "0400"
  Next
  'create criteria sheet/range
  Set wksThing = ActiveWorkbook.Worksheets.Add()
  wksThing.Visible = xlSheetHidden
  Set rngCriteria = wksThing.Range("A1")
  rngCriteria.Value = "GMT"
  rngCriteria.Offset(1).Formula = "=time(4,0,0)"
  rngCriteria.Offset(2).Formula = "=time(16,0,0)"
  Set rngCriteria = wksThing.Range(rngCriteria, rngCriteria.End(xlDown))
  
  'move data
  For Each vItem In colNames
    Set wksThing = ActiveWorkbook.Worksheets(vItem)
    wksThing.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, rngCriteria, Worksheets(wksThing.Name & "0400").Range("A1")
  Next
  
  'remove criteria worksheet
  rngCriteria.Worksheet.Delete
  
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  Application.Calculation = xlCalculationAutomatic
End Sub

Open in new window


===============
If your currency worksheets will have a three letter upper case name, we might use the following inclusion version of the If statement condition.
    If (wksThing.Name Like "[A-Z][A-Z][A-Z]") And (wksThing.Name Not Like "Sheet#*") Then
      colNames.Add wksThing.Name
    End If

Open in new window


===============
We can discuss initial conditions (assumptions) of the workbook.

Author

Commented:
That works fine now. Sorry for any confusion beforehand. Thanks for your help.
CC
Top Expert 2014

Commented:
You're welcome.

BTW...You can delete the following variable declaration statement.  It isn't used.

  Dim rngFiltered As Range

Open in new window

Most Valuable Expert 2011
Awarded 2010

Commented:
Thanks for taking over, aikimark!
Top Expert 2014

Commented:
@teylyn

No problem.  Hope you caught up on your beauty sleep.  Answering this question has renewed my interest in a couple of Excel articles, one of which has been on the to-finish list since last July.

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