Copy Data to a New Workbook Based on Dates

[K0st4din]

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:

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

 

[Trebor76]

Hi K0st4din,

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

'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]

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]

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]

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]

Comment out this line...

Set wbkOutput = Workbooks.Add

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

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

Hope that helps,

Robert

 

[K0st4din]

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

 

[K0st4din]

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

 

[Trebor76]

Thanks for letting us know your request is solved and your thanks