Try it this way. I'm not sure why you are removing the Header Row for copying though.
EDit: attachment removed and replaced with updated code below.
Try it this way. I'm not sure why you are removing the Header Row for copying though.
EDit: attachment removed and replaced with updated code below.
Hi Roy,
I should of stipulated in my first post that I copied the macro from another site.
We have a master spreadsheet that has about 20,000 rows of data on it by the end of the month. Someone has to manually filter between two dates, say 06/02/21 - 05/03/21 Highlight, copy, and paste the cells from rows A to T about 20,000 rows to a new workbook as an archive. They then remove the data from the master spreadsheet by deleting the rows.
I would like to keep the headers, but being a totally amateur to vba, I am still learning.
Unfortunately I can’t copy the master workbook as it’s part of a small system that user forms feed into, and all rows of data need to be accounted for by data range I.e 06/02/21 - 05/03/21 thus avoiding any duplicates.
I hope that explains a bit more as to the scenario, apologies for not being prior forthwith.
I've amended the code to copy with the header rows. It also checks that the End Date is not before the Start Date
Hi Roy,
when I press the command button the error as pictured attached pops up.
Sorry missed something out whilst editing.
Hi Roy,
I have got it working with your code thank you.
Just a couple of points to add, is it possible to write into the exisiting code to delete the filtered rows from the source file once it's copied them to the new workbook?
Also the column widths have not auto adjusted in the new workbook, is it possible to do that as well?
Thanks,
Lee
Try this
'This subroutine creates the new workbook based on input from the prompts
Public Sub CreateSubsetWorkbook(StartDate As String, EndDate As String)
Dim wbTo As Workbook
Dim rRng As Range
With Sheets("pandp")
If Not .AutoFilterMode Then .Range("A2").AutoFilter
.Range("A2").AutoFilter Field:=1, Criteria1:= _
">=" & CLng(DateValue(StartDate)), Operator:=xlAnd, Criteria2:="<=" & CLng(DateValue(EndDate))
Set wbTo = Workbooks.Add
.AutoFilter.Range.Cut ActiveSheet.Range("A3")
.Range("A3").AutoFilter
End With
ActiveSheet.Columns.AutoFit
ActiveWorkbook.SaveAs ThisWorkbook.Path & Application.PathSeparator & "Filtered Data", 51
ActiveWorkbook.Close True
'Let the user know our macro has finished!
MsgBox "Data transferred!"
End Sub
Display More
Hi Roy,
I’m getting a runtime when using the Cut option. It has also cut the whole sheet and not the filtered contents and pasted it into a new workbook just before I get the debug message.
Just a thought, but is it possible to clear contents instead and then sort to remove the blank rows?
That's certainly possible. I'll take a look as soon as I can
Thanks Roy,
I just think it would be good once it's copied the selected data to the new workbook, if it could then clear the contents of the copied data then do a sort to remove the blanks from the source file and then to save it of course.
I have inserted a sort at the start of the code as a kind of way to prep the spreadsheet prior to running the rest of the code. This puts the data in order on the new workbook. If some how i was able to run the same sort after the contents were removed then it would remove the blanks.
'This subroutine prompts the user to select dates
Public Sub PromptUserForInputDates()
ActiveSheet.Unprotect Password:="909"
Dim wsDB As Worksheet
Dim StartDate As Date, EndDate As Date
Set wsDB = ActiveWorkbook.Worksheets("Letters")
With wsDB.Sort
With .SortFields
.Clear
.Add Key:=wsDB.Range("A3:A50000" & LastRowTabel)
.Add Key:=wsDB.Range("B3:B50000" & LastRowTabel)
End With
.SetRange wsDB.Range("A3:T50000" & LastRowTabel)
.Header = xlNo 'Mogelijk xlNo, xlYes of xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Prompt the user to input the start date
StartDate = InputBox("Please enter the start date")
'Validate the input string
If Not IsDate(StartDate) Then
MsgBox "It looks like your entry is not a valid " & _
"date. Please retry with a valid date...", vbCritical, "Input Error"
Exit Sub
End If
'Prompt the user to input the end date
EndDate = InputBox("Please enter the end date")
'Validate the input string
If Not IsDate(EndDate) Then
MsgBox "It looks like your entry is not a valid " & _
"date. Please retry with a valid date...", vbCritical, "Input Error"
Exit Sub
End If
''///check dates are valis to use
If CLng(DateValue(StartDate)) > CLng(DateValue(EndDate)) Then
MsgBox "The End Date value cannot be before the End Date. " & _
"Please retry with a valid date...", vbCritical, "Input Error"
Exit Sub
End If
'Call the next subroutine, which will produce the output workbook
Call CreateSubsetWorkbook(Format(StartDate, "dd/mm/yyyy"), Format(EndDate, "dd/mm/yyyy"))
End Sub
'This subroutine creates the new workbook based on input from the prompts
Public Sub CreateSubsetWorkbook(StartDate As String, EndDate As String)
Dim wbTo As Workbook
Dim rRng As Range
With Sheets("Letters")
If Not .AutoFilterMode Then .Range("A2").AutoFilter
.Range("A2").AutoFilter Field:=1, Criteria1:= _
">=" & CLng(DateValue(StartDate)), Operator:=xlAnd, Criteria2:="<=" & CLng(DateValue(EndDate))
Set wbTo = Workbooks.Add
.AutoFilter.Range.Copy ActiveSheet.Range("A3")
.Range("A3").AutoFilter
End With
ActiveSheet.Columns.AutoFit
ActiveWorkbook.SaveAs ThisWorkbook.Path & Application.PathSeparator & "Archive of P&P Tracker", 51
ActiveWorkbook.Close True
'Let the user know our macro has finished!
MsgBox "Data transferred!"
ActiveSheet.Protect Password:="909"
End Sub
Display More
Try this
'This subroutine creates the new workbook based on input from the prompts
Public Sub CreateSubsetWorkbook(StartDate As String, EndDate As String)
Dim wbTo As Workbook
Dim rRng As Range
With Sheets("pandp")
If Not .AutoFilterMode Then .Range("A2").AutoFilter
.Range("A2").AutoFilter Field:=1, Criteria1:= _
">=" & CLng(DateValue(StartDate)), Operator:=xlAnd, Criteria2:="<=" & CLng(DateValue(EndDate))
Set wbTo = Workbooks.Add
.AutoFilter.Range.Copy ActiveSheet.Range("A3")
.AutoFilter.Range.EntireRow.Delete
.Range("A3").AutoFilter
End With
ActiveWorkbook.SaveAs ThisWorkbook.Path & Application.PathSeparator & "Filtered Data", 51
ActiveWorkbook.Close True
'Let the user know our macro has finished!
MsgBox "Data transferred!"
End Sub
Display More
Thanks Roy,
Is it possible over a period of time no rows will be available for new entry's as they have all been deleted or does it not work like that?
Thanks
Lee
I'll start a new thread as this is no longer relevent to my original post.
Carim, I’m still getting used to how the forum works. I would understand cross threading, but cross posting? ?? I started a new thread with a new subject as this thread was deviating away from my original post.
Obviously that must be a no no, so thanks for the heads up.
I’ve managed to use a bit of Roy’s code from his last post, and play about to get the header included. All sorted now, thanks all for the support throughout.
Don’t have an account yet? Register yourself now and be a part of our community!