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?
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

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

antoniokingAuthor Commented:
type mismatch on line
dt = DateSerial(myarray(2), myarray(1), myarray(0))
Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

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?

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.