如何从当前函数VBA Excel获取单元格行

时间:2013-09-24 11:54:05

标签: arrays excel function vba date

这是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

如何操作此函数以返回添加到我的月份数组中的每个值的单元格行。

存储这两个值的最佳方法是什么,即The Date(Oct-2011)&amp;行号(即456)

拖车阵列?然后返回一个包含这两个数组的数组?

任何人都可以提供这个问题的解决方案吗?

2 个答案:

答案 0 :(得分:5)

未完全测试

我只是一个快速的例子,我认为这就是你想要的,让我知道你可能需要做的任何改变,我很乐意提供帮助。

这是草率和未完成但据我所知,在您的实际数据的副本中测试,而不是在您的实际数据上。当我有更多的时间,我可以尝试清理更多。

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

答案 1 :(得分:0)

功能:

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