Copy dates from one sheet to another in range if date is old than 11 months

[DanSMT]

I am having an issue pulling dates from one workbook.sheet to another workbook.sheet. I've been working through the code. not sure if this is close or not.

The due1st spreadsheet's name will change daily. Need the code to reflect that also.

Dim sh As Worksheet, lr As Long, rng As Range, sh2 As Worksheet, lr2 As Long, c As Range
Set sh = Workbooks("Training Matrix.xls").Worksheets("Current Emp") 'Edit sheet name - Source
Set sh2 = Workbooks("DUE1st" & "*" & ".xls").Worksheets("Sheet1") 'Edit Sheet name - Destination
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh.Range("F6:BB400" & lr)
For Each c In rng
If DateValue(c.value) <= Workbooks("Training Matrix.xls").Worksheets("Current Emp Key").Cells("I2") Then
'DateValue(Date) Then
lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
c.EntireRow.Copy sh2.Range("A" & lr2)
End If
Next

 

[GWteB]

This line

Set sh2 = Workbooks("DUE1st" & "*" & ".xls").Worksheets("Sheet1") 'Edit Sheet name - Destination

will never work since the workbook name is not certain.
Furthermore it's recommended to avoid pulling such large amount of data from a worksheet range within a loop in which just one cell at a time is read from.
What are the names of the workbooks involved?
Are they located in the same drive / folder location?
Can you provide a sample of your worksheet(s)?

 

[DanSMT]

the files are located in the same drive. different folders though

Sorry I cant provide public information on the actual sheets though.

Source File:
"H:\TRAINING RECORDS\TRAINING MATRIX\Training Matrix.xls"

Destination File:
"H:\TRAINING RECORDS\DUE 1st\DUE1st*********" & ".xls"

The entire string of code is sloppy yet. But it is working up to the set Sh2 = workbooks lines

Private Sub DUE1_Click()
Dim objWorkbook As Workbook
Dim wb
Dim LstrDate As String
Dim dtStart As Date
Dim arr()
Dim counter&
Dim tmpDate As Date
Dim i&
Dim j&
Dim dateFound As Boolean
Dim lRow&
Dim rngStart As Range
Dim rngSource
Dim rngDest
Dim wksSource As Worksheet
Dim wksDest


    'open the workbook with data
    Set objWorkbook = Workbooks.Open( _
        "H:\TRAINING RECORDS\TRAINING MATRIX\Training Matrix.xls")
    'Create new workbook
    'Aname = ActiveWorkbook.Sheets(1).Range("a1").value
    Workbooks.Add
    ActiveWorkbook.SaveAs ("H:\TRAINING RECORDS\DUE 1st\DUE1st " & Format(Now(), "DDMMMYYYY") & ".xls")
    'copy headers
    Workbooks("Training Matrix.xls").Activate
    Sheets("Current Emp").Select
    Workbooks.Open Filename:="H:\TRAINING RECORDS\DUE 1st\DUE1st*********" & ".xls"


    Set wksSource = Workbooks("Training Matrix.xls").Sheets("Current Emp")

    'Copy Data
    Set rngSource = wksSource.Range("A1:BB1")
    '& CLastFundRow)
    rngSource.Copy
    'Paste Data Values
    
 'Dim wb As Workbook
    Dim wbName As String
   
    wbName = "DUE1"

    For Each wb In Application.Workbooks
        If wb.Name Like wbName & "*" Then
            Debug.Print wb.Name

            With wb.Sheets("Sheet1")
                '~~> Do something
            End With
        End If
    Next wb
    
    ActiveSheet.Paste
    
    Workbooks("Training Matrix.xls").Activate
    'Filter dates
    dtStart = DateAdd("m", -11, Date)
    
    'Get array of the unique dates to filter
    
Dim sh As Worksheet, lr As Long, rng As Range, sh2 As Worksheet, lr2 As Long, c As Range
Set sh = Workbooks("Training Matrix.xls").Worksheets("Current Emp") 'Edit sheet name - Source
Set sh2 = Workbooks("DUE1st" & "*********" & ".xls").Worksheets("Sheet1") 'Edit Sheet name - Destination
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh.Range("F6:BB400" & lr)
For Each c In rng
If DateValue(c.value) <= Workbooks("Training Matrix.xls").Worksheets("Current Emp Key").Cells("I2") Then
'DateValue(Date) Then
lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
c.EntireRow.Copy sh2.Range("A" & lr2)
End If
Next
    
End Sub

 

[GWteB]

Does the ****** represent sensitive information? If so, no problem, but the & characters are indicating otherwise, and moreover superfluous since it could be written as one string, ie
Workbooks("DUE1st*********.xls"). As I said before, this way one cannot reference a workbook, since it's name is not certain. I'm willing to look into it, but please answer the questions to help me in helping you.

 

[DanSMT]

the ******** represents todays date. Each time the file is saved im using todays date so it will not try to save over an existing file. If i use the same file name it doesnt update.

Now that im writing this im thinking that it wont matter that much. I can just use a save as function.

Do you agree?

 

[DanSMT]

Now that i've changed that it stops at;

Set rng = sh.Range("F6:BB400" & lr)

it says the range is empty.....

Not sure why though.

 

[GWteB]

Now that im writing this im thinking that it wont matter that much. I can just use a save as function.

It's much of a muchness, either way you are in the need of a known filename (in advance) in order to be able opening that file and setting a proper reference to it.

 

[DanSMT]

Yea, I did that. I dont think the worksheet lines are working at the bottom

Set sh = Workbooks("Training Matrix.xls").Worksheets("Current Emp") 'Edit sheet name - Source
Set sh2 = Workbooks("DUE1st.xls").Worksheets("Sheet1") 'Edit Sheet name - Destination

Private Sub DUE1_Click()
Dim objWorkbook As Workbook
Dim wb
Dim rngSource As Range
Dim rng
Dim c
Dim wksSource As Worksheet
Dim sh
Dim sh2
Dim wbName As String
Dim lr As Long
Dim lr2
    'open the workbook with data
    Application.DisplayAlerts = False
    Set objWorkbook = Workbooks.Open( _
        "H:\TRAINING RECORDS\TRAINING MATRIX\Training Matrix.xls")
        'Create new workbook
        Workbooks.Add
        ActiveWorkbook.SaveAs ("H:\TRAINING RECORDS\DUE 1st\DUE1st.xls")
        
        '" & Format(Now(), "DDMMMYYYY") & ".xls")
        'copy headers
        Workbooks("Training Matrix.xls").Activate
        Sheets("Current Emp").Select
        Workbooks.Open Filename:="H:\TRAINING RECORDS\DUE 1st\DUE1st.xls"
        '*********" & ".xls"
    Set wksSource = Workbooks("Training Matrix.xls").Sheets("Current Emp")
        'Copy Data
    Set rngSource = wksSource.Range("A1:BB1")
        rngSource.Copy
    'Paste Data Values
    wbName = "DUE1"
    For Each wb In Application.Workbooks
        If wb.Name Like wbName & "*" Then
            Debug.Print wb.Name
            With wb.Sheets("Sheet1")
                '~~> Do something
            End With
        End If
    Next wb
        ActiveSheet.Paste
        'Workbooks("Training Matrix.xls").Activate
    Set sh = Workbooks("Training Matrix.xls").Worksheets("Current Emp") 'Edit sheet name - Source
    Set sh2 = Workbooks("DUE1st.xls").Worksheets("Sheet1") 'Edit Sheet name - Destination
        lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
    Set rng = sh.Range("F6:BB400" & lr)
        For Each c In rng
            If DateValue(c.value) <= Workbooks("Training Matrix.xls").Worksheets("Current Emp Key").Cells("I2") Then
                'DateValue(Date) Then
                lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
                c.EntireRow.Copy sh2.Range("A" & lr2)
            End If
        Next
End Sub

 

[GWteB]

What's the name of your workbook in which your code is in?

 

[DanSMT]

training portal.xlsm