Copy Data to a New Workbook Based on Dates

K0st4din

Active Member
Joined
Feb 8, 2012
Messages
391
Office Version
  1. 2013
  2. 2011
  3. 2010
  4. 2007
Platform
  1. Windows
Hello, everyone,
after a lot of searching, i almost managed to find what i needed.
On this site ->>> How to Copy Data to a New Workbook Based on Dates | Dan Wagner Co
I found a macro that might work for my spreadsheets.
Since the macro is made to copy all worksheets by selecting specific dates, I have a workbook in which I also have worksheets that do not need to be copied.
I don't know how to change and what to change to do (Array ("City", "London", "ect to the end"), so I can control which worksheets to copy into a new workbook .
I ask for your help and assistance.
Thank you in advance
this is the code from the site:
VBA Code:
Option Explicit

'This subroutine prompts the user to select dates
Public Sub PromptUserForInputDates()
   
    Dim strStart As String, strEnd As String, strPromptMessage As String
   
    'Prompt the user to input the start date
    strStart = InputBox("Please enter the start date")
   
    'Validate the input string
    If Not IsDate(strStart) Then
        strPromptMessage = "Oops! It looks like your entry is not a valid " & _
                           "date. Please retry with a valid date..."
        MsgBox strPromptMessage
        Exit Sub
    End If
   
    'Prompt the user to input the end date
    strEnd = InputBox("Please enter the end date")
   
    'Validate the input string
    If Not IsDate(strStart) Then
        strPromptMessage = "Oops! It looks like your entry is not a valid " & _
                           "date. Please retry with a valid date..."
        MsgBox strPromptMessage
        Exit Sub
    End If
   
    'Call the next subroutine, which will do produce the output workbook
    Call CreateSubsetWorkbook(strStart, strEnd)
   
End Sub

'This subroutine creates the new workbook based on input from the prompts
Public Sub CreateSubsetWorkbook(StartDate As String, EndDate As String)
   
    Dim wbkOutput As Workbook
    Dim wksOutput As Worksheet, wks As Worksheet
    Dim lngLastRow As Long, lngLastCol As Long, lngDateCol As Long
    Dim rngFull As Range, rngResult As Range, rngTarget As Range
   
    'Set references up-front
    lngDateCol = 3 '<~ we know dates are in column C
    Set wbkOutput = Workbooks.Add
   
    'Loop through each worksheet
    For Each wks In ThisWorkbook.Worksheets '------>>>>>> I think there needs to be a change somewhere, not for all worksheets
        With wks
       
            'Create a new worksheet in the output workbook
            Set wksOutput = wbkOutput.Sheets.Add
            wksOutput.Name = wks.Name
           
            'Create a destination range on the new worksheet that we
            'will copy our filtered data to
            Set rngTarget = wksOutput.Cells(1, 1)
       
            'Identify the data range on this sheet for the autofilter step
            'by finding the last row and the last column
            lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _
                                 SearchOrder:=xlByRows, _
                                 SearchDirection:=xlPrevious).Row
            lngLastCol = .Cells.Find(What:="*", LookIn:=xlFormulas, _
                                 SearchOrder:=xlByColumns, _
                                 SearchDirection:=xlPrevious).Column
            Set rngFull = .Range(.Cells(1, 1), .Cells(lngLastRow, lngLastCol))
           
            'Apply a filter to the full range to get only rows that
            'are in between the input dates
            With rngFull
                .AutoFilter Field:=lngDateCol, _
                            Criteria1:=">=" & StartDate, _
                            Criteria2:="<=" & EndDate
               
                'Copy only the visible cells and paste to the
                'new worksheet in our output workbook
                Set rngResult = rngFull.SpecialCells(xlCellTypeVisible)
                rngResult.Copy Destination:=rngTarget
            End With
           
            'Clear the autofilter safely
            .AutoFilterMode = False
            If .FilterMode = True Then
                .ShowAllData
            End If
        End With
    Next wks
   
    'Let the user know our macro has finished!
    MsgBox "Data transferred!"

End Sub
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,805
Hi K0st4din,

I have tweaked the CreateSubsetWorkbook macro to include an array of the sheet tab(s) you want copied to the new workbook:

Code:
'This subroutine creates the new workbook based on input from the prompts
Public Sub CreateSubsetWorkbook(StartDate As String, EndDate As String)
   
    Dim wbkOutput As Workbook
    Dim wksOutput As Worksheet, wks As Worksheet
    Dim lngLastRow As Long, lngLastCol As Long, lngDateCol As Long
    Dim rngFull As Range, rngResult As Range, rngTarget As Range
    Dim varMySheets As Variant
    
    varMySheets = Array("City", "London") 'Sheet name(s) to be copied to new workbook
   
    'Set references up-front
    lngDateCol = 3 '<~ we know dates are in column C
    Set wbkOutput = Workbooks.Add
   
    'Loop through each worksheet
    For Each wks In ThisWorkbook.Worksheets '------>>>>>> I think there needs to be a change somewhere, not for all worksheets
        If IsNumeric(Application.Match(wks.Name, varMySheets, 0)) Then
            With wks
        
                 'Create a new worksheet in the output workbook
                 Set wksOutput = wbkOutput.Sheets.Add
                 wksOutput.Name = wks.Name
                
                 'Create a destination range on the new worksheet that we
                 'will copy our filtered data to
                 Set rngTarget = wksOutput.Cells(1, 1)
            
                 'Identify the data range on this sheet for the autofilter step
                 'by finding the last row and the last column
                 lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _
                                      SearchOrder:=xlByRows, _
                                      SearchDirection:=xlPrevious).Row
                 lngLastCol = .Cells.Find(What:="*", LookIn:=xlFormulas, _
                                      SearchOrder:=xlByColumns, _
                                      SearchDirection:=xlPrevious).Column
                 Set rngFull = .Range(.Cells(1, 1), .Cells(lngLastRow, lngLastCol))
                
                 'Apply a filter to the full range to get only rows that
                 'are in between the input dates
                 With rngFull
                     .AutoFilter Field:=lngDateCol, _
                                 Criteria1:=">=" & StartDate, _
                                 Criteria2:="<=" & EndDate
                    
                     'Copy only the visible cells and paste to the
                     'new worksheet in our output workbook
                     Set rngResult = rngFull.SpecialCells(xlCellTypeVisible)
                     rngResult.Copy Destination:=rngTarget
                 End With
                
                 'Clear the autofilter safely
                 .AutoFilterMode = False
                 If .FilterMode = True Then
                     .ShowAllData
                 End If
            End With
        End If
    Next wks
   
    'Let the user know our macro has finished!
    MsgBox "Data transferred!"

End Sub

Regards,

Robert
 

K0st4din

Active Member
Joined
Feb 8, 2012
Messages
391
Office Version
  1. 2013
  2. 2011
  3. 2010
  4. 2007
Platform
  1. Windows
Thank you very much for your help.
It's cool now and I can decide which worksheets to export.
Be alive and well and still help those in need.
P.S. - I would like to ask you, is there anything else you can add to say exactly in which workbook the information is stored?
For example, my workbook I always call it "Product Sales"
 

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,805
P.S. - I would like to ask you, is there anything else you can add to say exactly in which workbook the information is stored?
For example, my workbook I always call it "Product Sales"

Do you mean instead of opening a new workbook?
 

K0st4din

Active Member
Joined
Feb 8, 2012
Messages
391
Office Version
  1. 2013
  2. 2011
  3. 2010
  4. 2007
Platform
  1. Windows

ADVERTISEMENT

Yes exactly. In the one where I work, I put this macro. I open the second one and go back to the first one to go are what I want. Hypothetically my main workbook is called Sales, the one in which I carry the information is called Monthly Sales.
 

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,805
Comment out this line...

Code:
Set wbkOutput = Workbooks.Add

...and replace it with this (as long as the file is open and change the extension to suit):

Code:
Set wbkOutput = Workbooks("Product Sales.xlsm")

Hope that helps,

Robert
 

K0st4din

Active Member
Joined
Feb 8, 2012
Messages
391
Office Version
  1. 2013
  2. 2011
  3. 2010
  4. 2007
Platform
  1. Windows

ADVERTISEMENT

Thank you very much. As soon as I get home I will test it and return an answer. Be alive and well.
 

K0st4din

Active Member
Joined
Feb 8, 2012
Messages
391
Office Version
  1. 2013
  2. 2011
  3. 2010
  4. 2007
Platform
  1. Windows
Hi, I'm already home and trying change.
Everything is as I want it to be. :)
Thank you very much for your cooperation.
Good thing there are people like you to help us.
Thanks again
 

Forum statistics

Threads
1,144,582
Messages
5,725,119
Members
422,590
Latest member
Mikeyyy

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top