if workbooks worksheets name is a date between date range, copy data to another workbook.

Please can someone help me.

I would like a macro that will open a workbook, and check the names of all the sheets in the workbook.
all names in the workbook follow the format... "CHAPS dd.mm.yy"
Where dd mm yy is a date.

If the name of the sheet is between specfied dates dteReportDate1 and dteReportDate2 then copy rows 3 onwards to the original workbook worksheet name "CHAPSWEEK1"

If there is already date on CHAPSWEEK1 the copied date should be appended to the sheet.
Sub RunCHAPSImport()
Dim strImportWorkBookName As String
Dim dteReportDate1 as Date
Dim dteReportDate2 as Date
Dim wbActiveWorkbook as Workbook

Set wbActiveWorkbook = ThisWorkbook
Set dteReportDate1 = "28/02/11"
Set dteReportDate1 = "07/03/11"

    Application.DisplayAlerts = False
    Set strImportWorkBookName = Workbooks.Open(Filename:="C:\InputFolder\CHAPS.xls")
    Application.DisplayAlerts = True

End Sub

Open in new window

Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Ok, the code is ready, however can you share a sample for both sheets so that I can get the references correct?

Stepping out for a moment.


Option Explicit

Private Sub Usage()
    '~~> dteReportDate1 and dteReportDate2 are the comparision dates
    '~~> The path of the file is which you want to open and check
    CopyRecords #1/1/2011#, #2/2/2011#, "C:\Temp\MyWorkbook.xls"
End Sub

Private Sub CopyRecords(dteReportDate1 As Date, dteReportDate2 As Date, spath As String)
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim dt As Date
    Dim sName As String, MyArrray() As String
    Dim ws1LastRow As Long, ws2LastRow As Long, i As Long
    On Error GoTo Whoa
    Application.ScreenUpdating = False
    Set wb1 = ActiveWorkbook
    Set ws1 = wb1.Sheets("CHAPSWEEK1")
    ws1LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    Set wb2 = Workbooks.Open(spath)
    For Each ws In wb2.Worksheets
        sName = Replace(ws.Name, "CHAPS ", "")
        MyArrray = Split(sName, ".")
        dt = DateSerial(myarray(2), myarray(1), myarray(0))
        If dt > dteReportDate1 And dt < dteReportDate2 Then
            Set ws2 = ws
            ws2LastRow = ws2.Range("A" & Rows.Count).End(xlUp).Row
            For i = 3 To ws2LastRow
                ws2.Rows(i).Copy ws1.Rows(ws1LastRow)
                ws1LastRow = ws1LastRow + 1
            Next i
        End If
    wb2.Close savechanges:=False
    Set ws2 = Nothing
    Set wb2 = Nothing
    MsgBox "Done"
    Application.ScreenUpdating = True
    Exit Sub
    MsgBox Err.Description
    Resume LetsContinue
End Sub

Open in new window


Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
antoniokingAuthor Commented:
type mismatch on line
dt = DateSerial(myarray(2), myarray(1), myarray(0))
Exploring SharePoint 2016

Explore SharePoint 2016, the web-based, collaborative platform that integrates with Microsoft Office to provide intranets, secure document management, and collaboration so you can develop your online and offline capabilities.

Sorry try this

dt = DateSerial(Val(Trim(myarray(2))), Val(Trim(myarray(1))), Val(Trim(myarray(0))))

antoniokingAuthor Commented:
Now getting subscript out of range on that line. thanks
Can you upload the file so that I can test?

It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.