Wie man die Zellenreihe aus der aktuellen Funktion in VBA Excel erhält

Question

Hier ist die VBA-Funktion, die ein Array mit einem einzigartigen Satz von Monaten aus einem Startmonat und einem Endmonat generiert:

Funktion get_months(matrix_height As Integer) As Variant

    Worksheets("Analyse").Activate

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

    Dim dateRange As Bereich
    Dim months_array() Als String 'Array für Monate

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

    On Error Resume Next

    Dim currentRange Wie Bereich
    Für Jeden currentRange In dateRange.Zellen
        Wenn currentRange.Value <> "" Dann
            Dim tempDate Als Datum: tempDate = CDate(currentRange.Text) 'Den Text in ein Datum konvertieren
            Dim parsedDateString Als String: parsedDateString = Format(tempDate, "MMM-JJJJ")
            uniqueMonths.Add Item:=parsedDateString, Key:=parsedDateString
        Ende Wenn
    Nächster currentRange

    On Error GoTo 0 'Standardfehlerbehandlung aktivieren

    'Durch die Sammlung iterieren und die eindeutigen Monate und Jahre anzeigen
    Dim uniqueMonth Als Variant
    Dim counter Als Integer
    counter = 0

    Für Jeden uniqueMonth In uniqueMonths

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

    Nächster uniqueMonth

    get_months = months_array

Ende Funktion

Wie kann ich diese Funktion manipulieren, um die Zellenzeilen jedes der Werte zurückzugeben, die meinem Monatsarray hinzugefügt werden.

Was wäre der beste Weg, um diese beiden Werte zu speichern, d.h. das Datum (Okt-2011) und die Zeilennummer (z.B. 456)

Zwei Arrays? Dann ein Array mit diesen beiden Arrays darin zurückgeben?

Kann mir jemand eine Lösung für dieses Problem geben?

Answer 1

NICHT VOLLSTÄNDIG GETESTET

Nur ein schnelles Beispiel, das ich zusammengeworfen habe. Ich denke, das ist wonach du suchst. Lass mich wissen, falls du Änderungen benötigst und ich werde gerne helfen.

Dies ist schlampig und unvollendet, aber es funktioniert, soweit ich weiß. Teste es mit einer Kopie deiner tatsächlichen Daten und nicht mit deinen tatsächlichen Daten. Wenn ich etwas mehr Zeit habe, werde ich versuchen, es aufzuräumen.

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

Und kann wie folgt aufgerufen werden:

Sub CallFunction()
Dim y As Variant

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

End Sub

Answer 2

Funktion:

Funktion get_months() Als Variant

    Dim UnqMonths Als Collection
    Dim ws Als Arbeitsblatt
    Dim rngCell Als Bereich
    Dim arrOutput() Als Variant
    Dim varRow Als Variant
    Dim strRows Als String
    Dim strDate Als String
    Dim lUnqCount Als Long
    Dim i Als Long

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

    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

Aufruf und Ausgabe:

Sub tgr()

    Dim my_months Als 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("Eindeutiger Monat", "Analyserow #")
            .Font.Bold = True
            .EntireColumn.AutoFit
        End With
    End With

End Sub