Как получить ячейки строки из текущей функции VBA Excel

Question

Вот функция VBA, которая заполняет массив с уникальным набором месяцев, генерируется из стартового месяца и конец месяца:

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 

Как я могу манипулировать эта функция возвращает строки ячеек каждого из значений, которые добавляются в мой массив месяцев.

Что бы быть лучшим способом сохранить эти два значения, т.е. на дату (октябрь-2011) & номер строки (т.е. 456)

буксировочные массивы? Затем верните массив с этими двумя массивами внутри него?

Может ли кто-нибудь дать решение этой проблемы?

Answer 1

НЕ ПОЛНОСТЬЮ ПРОВЕРЕНО

Просто быстрый пример, который я кинул вместе думать это то, что вы ищете, дайте мне знать о любых изменениях, которые могут понадобиться, и я был бы рад помочь.

Это неряшливый и незавершенный, но работающий, насколько я знаю, тест в копии ваших фактических данных, а не на ваши фактические данные. Когда я получу еще какое-то время, я могу попытаться очистить больше.

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 

И можно назвать как:

Sub CallFunction() 
Dim y As Variant 

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

End Sub 

Answer 2

Функция:

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 

вызовов и выход:

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