How to get cell row from current function VBA Excel

Question

Here is the VBA function that populates an array with a unique set of months, generated from a start month and an end month:

Function get_months(matrix_height As Integer) As Variant

    Worksheets("Analysis").Activate

    Dim date_range As String
    Dim column As String
    Dim uniqueMonths As Collection
    Set uniqueMonths = New Collection

    Dim dateRange As range
    Dim months_array() As String 'array for months

    column = Chr(64 + 1) 'A
    date_range = column & "2:" & column & matrix_height
    Set dateRange = range(date_range)

    On Error Resume Next

    Dim currentRange As range
    For Each currentRange In dateRange.Cells
        If currentRange.Value <> "" Then
            Dim tempDate As Date: tempDate = CDate(currentRange.Text) 'Convert the text to a Date
            Dim parsedDateString As String: parsedDateString = Format(tempDate, "MMM-yyyy")
            uniqueMonths.Add Item:=parsedDateString, Key:=parsedDateString
        End If
    Next currentRange

    On Error GoTo 0 'Enable default error trapping

    'Loop through the collection and view the unique months and years
    Dim uniqueMonth As Variant
    Dim counter As Integer
    counter = 0

    For Each uniqueMonth In uniqueMonths

        ReDim Preserve months_array(counter)
        months_array(counter) = uniqueMonth
        Debug.Print uniqueMonth
        counter = counter + 1

    Next uniqueMonth

    get_months = months_array

End Function

How can I manipulate this function to return the cell rows of each of the values that are being added to my months array.

What would be the best way to store these two values ie The Date (Oct-2011) & the Row Number (ie 456)

Tow arrays? Then return an array with these two arrays within it?

Can anyone give provide a solution to this problem?

Answer 1

NOT FULLY TESTED

Just a quick example I threw together think this is what you are looking for, let me know of any changes you may need and I'd be glad to help.

This is sloppy and unfinished but working, as far as I know, Test in a copy of your actual data and not on your actual data. When I get some more time I can try to clean up more.

Function get_months(matrix_height As Integer) As Variant   
    Dim uniqueMonth As Variant
    Dim counter As Integer
    Dim date_range() As Variant
    Dim column As String
    Dim uniqueMonths As Collection
    Dim rows As Collection
    Set uniqueMonths = New Collection
    Set rows = New Collection

    Dim dateRange As Range
    Dim months_array() As String 'array for months

    date_range = Worksheets("Analysis").Range("A2:A" & matrix_height + 1).Value

    On Error Resume Next

    For i = 1 To matrix_height 
        If date_range(i, 1) <> "" Then
            Dim parsedDateString As String: parsedDateString = Format(date_range(i, 1), "MMM-yyyy")
            uniqueMonths.Add Item:=parsedDateString, Key:=parsedDateString
            If Err.Number = 0 Then rows.Add Item:=i + 1
            Err.Clear
        End If
    Next i

    On Error GoTo 0 'Enable default error trapping

    'Loop through the collection and view the unique months and years
    ReDim months_array(uniqueMonths.Count, 2)

    For y = 1 To uniqueMonths.Count 
        months_array(y, 1) = uniqueMonths(y)
        months_array(y, 2) = rows(y)
    Next y

    get_months = months_array

End Function

And can be called like:

Sub CallFunction()
Dim y As Variant

y = get_months(WorksheetFunction.Count([A:A]) - 1)

End Sub

Answer 2

Function:

Function get_months() As Variant

    Dim UnqMonths As Collection
    Dim ws As Worksheet
    Dim rngCell As Range
    Dim arrOutput() As Variant
    Dim varRow As Variant
    Dim strRows As String
    Dim strDate As String
    Dim lUnqCount As Long
    Dim i As Long

    Set UnqMonths = New Collection
    Set ws = Sheets("Analysis")

    On Error Resume Next
    For Each rngCell In ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp)).Cells
        If IsDate(rngCell.Text) Then
            strDate = Format(CDate(rngCell.Text), "mmm-yyyy")
            UnqMonths.Add strDate, strDate
            If UnqMonths.Count > lUnqCount Then
                lUnqCount = UnqMonths.Count
                strRows = strRows & " " & rngCell.Row
            End If
        End If
    Next rngCell
    On Error GoTo 0

    If lUnqCount > 0 Then
        ReDim arrOutput(1 To lUnqCount, 1 To 2)
        For i = 1 To lUnqCount
            arrOutput(i, 1) = UnqMonths(i)
            arrOutput(i, 2) = Split(strRows, " ")(i)
        Next i
    End If

    get_months = arrOutput

End Function

Call and output:

Sub tgr()

    Dim my_months As Variant

    my_months = get_months

    With Sheets.Add(After:=Sheets(Sheets.Count))
        .Range("A2").Resize(UBound(my_months, 1), UBound(my_months, 2)).Value = my_months
        With .Range("A1:B1")
            .Value = Array("Unique Month", "Analysis Row #")
            .Font.Bold = True
            .EntireColumn.AutoFit
        End With
    End With

End Sub