CODEWITHSUNDEEP
vbaexcel
FrenchConnections
FrenchConnections

Reputation: 391

Match Month-Year of one Date to the Day-Month of another Date

I am working on a macro that assigns values based on matches between dates. My macro is supposed to loop through a column of dates and match the month-year of each date to a row with other dates. If there is a match, a value in a corresponding column needs to be copies over. The issues I am running into is comparing an extracted month-year of one date with the month-date of another. A simple version of what I want the data to look like is this:

enter image description here

As you can see, the value is copied over into the horizontal part that corresponds to the date next to the value. It is copied over a fixed number of times depending on the term.

The issue I am running into is in matching the date. I am trying to compare the month-year of the Date with the month-year in row 1, but my script is only functioning when there is an exact match, i.e. when the date in column B matches the date in row 1. So if a date in column B is 1/1/2011, then it gets copied into the correct cell, but otherwise it does not get copied at all. Here is the script I am working on (note that I only have it set up for quarterly terms - when I get that to work, I will add the other terms to the If-statement.

Sub End_Collate()

    Dim i As Long, j As Long, k As Long
    Dim ws As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim wb As Workbook
    Dim lastrow As Long, lastcolumn As Long, lastrow_reps As Long
    Dim reps As Variant, reps_list As Variant
    Dim min_date As Date, min_date_format As Date, date_diff As Integer
    Dim cell As Range

    Set wb = ActiveWorkbook
    Set ws2 = wb.Sheets("data")
    Set ws = wb.Sheets("Rep_Commission")

    lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    Set reps_list = ws.Range("A3:A" & (lastrow))
    date_diff = DateDiff("m", min_date, Date)

    'loop through each sheet and add in the correct dates to the correct range
    For Each reps In reps_list
        min_date = Application.WorksheetFunction.Min(ws2.Range("H2:H" &
        Cells(Rows.Count, 1).End(xlUp).Row))
        i = 0
        With wb.Worksheets(reps.Text)
            Do While DateDiff("m", min_date, Date) <> 0
                Worksheets(reps.Text).Range("S1").Offset(0, i).Value = min_date
                min_date = DateAdd("m", 1, min_date)
                i = i + 1
            Loop
        End With
    Next reps

    For Each reps In reps_list
        i = 0
        j = 0
        lastrow_reps = Worksheets(reps.Text).Cells(Rows.Count, 1).End(xlUp).Row
        lastcolumn = Worksheets(reps.Text).Cells(1, Columns.Count).End(xlToLeft).Column
        For i = 2 To lastrow_reps
            'currently this is quarterly - once I get it to work I will add options for daily, monthly etc.
            If Worksheets(reps.Text).Cells(i, 11).Value = "Quarterly" Then
                With Worksheets(reps.Text)
                    For j = 18 To lastcolumn
                        If (DatePart("m", .Cells(i, 8)) & DatePart("y", .Cells(i, 8))) = (DatePart("m", .Cells(1, j)) & DatePart("y", .Cells(1, j))) Then
                            .Cells(i, j) = .Cells(i, 18)
                        Else                     'Do nothing (will add error handling here)
                        End If
                    Next j
                End With
            End If
        Next i
    Next reps

End Sub

Upvotes: 1

Views: 583

Answers (1)

Comintern
Comintern

Reputation: 22195

You're using the wrong interval for DatePart (the documentation is here).

"y" is the day of the year, not the year. Your code looks like it should work if you replace the interval with "yyyy".

This demonstrates:

Public Sub DatePartIntervals()
    Debug.Print DatePart("y", Now)
    Debug.Print DatePart("yyyy", Now)
End Sub

Upvotes: 2

Related Questions