如何使用VBAbuild立dynamic的单元格范围输出function

我正在构build一个函数，当您select一个单元格时，输出是从select到同一列上最后一个填充的单元格行的单元格区域。

这是代码，完美的作品。

''Get the cell range from selection to last cell Function CellRange(CellA As Range) CellRange = CellA.Address + ":" + CellA.End(xlDown).Address End Function 

问题：我想更新这个代码，所以当用于date时，用户可以过滤三个选项：年初至今，全部（所有时间 – 即获取所有数据），一年（即2015/2014 / 2013等）

我的最终目标是让用户在date的范围列中select一个单元格，并inputYTD或ALL或给定年份（即2014 ），并使用他的filter获取范围。

示例：用户写入=cellrange(A2,2014) ，它应该产生$A$2:$A$23 ，如果用户更改为=cellrange(A2,2014)则应该产生$A$24:$A$40图片。

我尝试了各种各样的循环或计数，但是我觉得很失落，因为我的一些尝试显然没有任何意义。

我正在寻找一些帮助：指导或解决这个问题最好，因为我想解决这个问题后，我想build立它（因此，为什么我在VBA上做）。

Answer 1

这是一个短得多的解决scheme，适用于所有三种情况，并不需要数据工作表处于活动状态：

 Public Function cellrange(rDates As Range, vFilter As Variant) As String Dim i As Long, ndx1 As Long, ndx2 As Long, r As Range, vA As Variant, bErr As Boolean, bAll As Boolean bErr = True If IsDate(rDates) Then With rDates.EntireColumn i = rDates.Parent.Evaluate("count(" & .Address & ")") Set r = .Cells(1 - i + rDates.Parent.Evaluate("index(" & .Address & ",match(9.9E+307," & .Address & "))").Row).Resize(i, 1) End With vA = r.Value Select Case LCase(vFilter) Case "all": bErr = 0: bAll = 1 Case "ytd" For i = 1 To UBound(vA) If ndx1 = 0 And Year(vA(i, 1)) = Year(Date) Then ndx1 = i If vA(i, 1) <= Date Then ndx2 = i Next Case Else 'year vFilter = Val(vFilter) If vFilter Then For i = 1 To UBound(vA) If ndx1 = 0 And Year(vA(i, 1)) = vFilter Then ndx1 = i If ndx1 And Year(vA(i, 1)) = vFilter Then ndx2 = i Next End If End Select If Not bAll Then If ndx1 > 0 And ndx2 > 0 Then Set r = r.Range(r.Parent.Cells(ndx1, 1), r.Parent.Cells(ndx2, 1)): bErr = False If Not bErr Then cellrange = r.Address Else cellrange = CVErr(xlErrValue) End If End Function 

Answer 2

我写了一些代码，我认为它捕捉了你正在做的事情。 我将以几点说明。 （1）如果CellA不是Date值（我认为这是出于自我解释的原因），代码将抛出#Value错误。 （2）如果公式中的年份条目与CellA中的年份不匹配，则也会抛出#Value 。 我不确定你是否想要返回这种types的治疗方式，但是我个人认为，如果用户指向2014年的CellA ，并且他们正在寻找2013年的date，那么对于用户来说，这将是相当混乱的。 让我知道如果你想改变。

看看代码，给它一些testing用例，并让我知道是否还有其他需要修改。

基于新的信息编辑：我没有像往常那样花费太多的时间来testing这些代码，而是看看它是否对您更好。

 Function cellrange(cellA As Range, vFilter As Variant) As String Dim rStart As Range Dim rEnd As Range Dim bFinished As Boolean Dim dToday As Date Dim nOffset As Integer 'Throw an error if cell is not a date cell If Not IsDate(cellA) Then cellrange = CVErr(xlErrValue) End If If IsNumeric(vFilter) Then If vFilter = Year(cellA) Then 'Below code if there is a year entered as vFilter Set rStart = cellA bFinished = False 'Loop to find start of year range Do If IsDate(rStart.Offset(-1)) Then If Year(rStart.Offset(-1)) = vFilter Then Set rStart = rStart.Offset(-1) Else bFinished = True End If Else bFinished = True End If Loop While bFinished = False 'Loop to find end of year range Set rEnd = cellA bFinished = False Do If IsDate(rEnd.Offset(1)) Then If Year(rEnd.Offset(1)) = vFilter Then Set rEnd = rEnd.Offset(1) Else bFinished = True End If Else bFinished = True End If Loop While bFinished = False cellrange = rStart.Address & ":" & rEnd.Address Else If Year(cellA) > vFilter Then nOffset = -1 Else nOffset = 1 End If Set rEnd = cellA bFinished = False Do If IsDate(rEnd.Offset(nOffset)) Then If Year(rEnd.Offset(nOffset)) <> vFilter Then Set rEnd = rEnd.Offset(nOffset) Else Set rEnd = rEnd.Offset(nOffset) bFinished = True End If Else bFinished = True End If Loop While bFinished = False Set rStart = rEnd bFinished = False Do If IsDate(rStart.Offset(nOffset)) Then If Year(rStart.Offset(nOffset)) = Year(rStart) Then Set rStart = rStart.Offset(nOffset) Else bFinished = True End If Else bFinished = True End If Loop While bFinished = False If nOffset = -1 Then cellrange = rStart.Address & ":" & rEnd.Address Else cellrange = rEnd.Address & ":" & rStart.Address End If End If Else If vFilter = "YTD" Then 'Below code if there is 'YTD' entered as vFilter Set rStart = cellA bFinished = False dToday = Date 'Loop to find start of year range Do If IsDate(rStart.Offset(-1)) Then If Year(rStart.Offset(-1)) = Year(rStart) Then Set rStart = rStart.Offset(-1) Else bFinished = True End If Else bFinished = True End If Loop While bFinished = False 'Loop to find end of year range Set rEnd = cellA bFinished = False Do If rEnd > dToday Then nOffset = -1 If IsDate(rEnd.Offset(nOffset)) Then If Year(rEnd.Offset(nOffset)) = Year(rEnd) And rEnd.Offset(nOffset) >= dToday Then Set rEnd = rEnd.Offset(nOffset) Else bFinished = True End If Else bFinished = True End If Else nOffset = 1 If IsDate(rEnd.Offset(nOffset)) Then If Year(rEnd.Offset(nOffset)) = Year(rEnd) And rEnd.Offset(nOffset) <= dToday Then Set rEnd = rEnd.Offset(nOffset) Else bFinished = True End If Else bFinished = True End If End If Loop While bFinished = False cellrange = rStart.Address & ":" & rEnd.Address Else 'Below returns the 'ALL' case Set rStart = cellA bFinished = False 'Loop to find start of year range Do If IsDate(rStart.Offset(-1)) Then Set rStart = rStart.Offset(-1) Else bFinished = True End If Loop While bFinished = False 'Loop to find end of year range Set rEnd = cellA bFinished = False Do If IsDate(rEnd.Offset(1)) Then Set rEnd = rEnd.Offset(1) Else bFinished = True End If Loop While bFinished = False cellrange = rStart.Address & ":" & rEnd.Address End If End If End Function 

---

较旧的预编辑代码

 Function cellrange(cellA As Range, vFilter As Variant) As String Dim rStart As Range Dim rEnd As Range Dim bFinished As Boolean Dim dToday As Date Dim nOffset As Integer 'Throw an error if cell is not a date cell If Not IsDate(cellA) Then cellrange = CVErr(xlErrValue) End If 'Throw an error if the cell year does not match the value being searched If IsNumeric(vFilter) And vFilter <> Year(cellA) Then cellrange = CVErr(xlErrValue) End If If IsNumeric(vFilter) Then 'Below code if there is a year entered as vFilter Set rStart = cellA bFinished = False 'Loop to find start of year range Do If IsDate(rStart.Offset(-1)) Then If Year(rStart.Offset(-1)) = vFilter Then Set rStart = rStart.Offset(-1) Else bFinished = True End If Else bFinished = True End If Loop While bFinished = False 'Loop to find end of year range Set rEnd = cellA bFinished = False Do If IsDate(rEnd.Offset(1)) Then If Year(rEnd.Offset(1)) = vFilter Then Set rEnd = rEnd.Offset(1) Else bFinished = True End If Else bFinished = True End If Loop While bFinished = False cellrange = rStart.Address & ":" & rEnd.Address Else If vFilter = "YTD" Then 'Below code if there is 'YTD' entered as vFilter Set rStart = cellA bFinished = False dToday = Date 'Loop to find start of year range Do If IsDate(rStart.Offset(-1)) Then If Year(rStart.Offset(-1)) = Year(rStart) Then Set rStart = rStart.Offset(-1) Else bFinished = True End If Else bFinished = True End If Loop While bFinished = False 'Loop to find end of year range Set rEnd = cellA bFinished = False Do If rEnd > dToday Then nOffset = -1 If IsDate(rEnd.Offset(nOffset)) Then If Year(rEnd.Offset(nOffset)) = Year(rEnd) And rEnd.Offset(nOffset) >= dToday Then Set rEnd = rEnd.Offset(nOffset) Else bFinished = True End If Else bFinished = True End If Else nOffset = 1 If IsDate(rEnd.Offset(nOffset)) Then If Year(rEnd.Offset(nOffset)) = Year(rEnd) And rEnd.Offset(nOffset) <= dToday Then Set rEnd = rEnd.Offset(nOffset) Else bFinished = True End If Else bFinished = True End If End If ' If IsDate(rEnd.Offset(nOffset)) Then ' If Year(rEnd.Offset(nOffset)) = Year(rEnd) And rEnd.Offset(nOffset) < dToday Then ' Set rEnd = rEnd.Offset(nOffset) ' Else ' bFinished = True ' End If ' Else ' bFinished = True ' End If Loop While bFinished = False cellrange = rStart.Address & ":" & rEnd.Address Else 'Below returns the 'ALL' case Set rStart = cellA bFinished = False 'Loop to find start of year range Do If IsDate(rStart.Offset(-1)) Then Set rStart = rStart.Offset(-1) Else bFinished = True End If Loop While bFinished = False 'Loop to find end of year range Set rEnd = cellA bFinished = False Do If IsDate(rEnd.Offset(1)) Then Set rEnd = rEnd.Offset(1) Else bFinished = True End If Loop While bFinished = False cellrange = rStart.Address & ":" & rEnd.Address End If End If End Function 

Answer 3

稍微更紧凑的function…

要在电子表格中使用它，枚举值将不起作用; 例如。 使用'= CellRange（C3,1）'

 Public Enum xlDateAction xlYearToDate = 1 xlCurrentYear = 2 xlAll = 3 End Enum Public Function CellRange(SrcCell As Range, DtRange As xlDateAction) As String Application.ScreenUpdating = False If Not IsDate(SrcCell.Value) Then Exit Function Dim CellDate As Date: CellDate = SrcCell.Value Dim EndCell As Range Set EndCell = Columns(SrcCell.Column).Find(What:="", After:=[SrcCell]).Offset(-1, 0) Dim StartCell As Range: Set StartCell = SrcCell Do Until StartCell.Row = 1 Or Not IsDate(StartCell.Value) Set StartCell = StartCell.Offset(-1, 0) Loop If Not IsDate(StartCell.Value) Then Set StartCell = StartCell.Offset(1, 0) If DtRange <> xlAll Then Dim SrcYear As Long: SrcYear = Year(CDate(SrcCell.Value)) Do Until StartCell.Address = SrcCell.Address Or Year(CDate(StartCell.Value)) = SrcYear If Year(CDate(StartCell.Value)) < SrcYear Then Set StartCell = StartCell.Offset(1, 0) Loop If DtRange = xlCurrentYear Then Do Until EndCell.Address = SrcCell.Address Or Year(CDate(EndCell.Value)) = SrcYear If Year(CDate(EndCell.Value)) > SrcYear Then Set EndCell = EndCell.Offset(-1, 0) Loop Else Set EndCell = SrcCell End If End If CellRange = Range(StartCell, EndCell).Address Application.ScreenUpdating = True End Function 

******* 更新 *******

增加了一年覆盖function，我认为现在应该做你想要的范围select…（也调整了枚举，因为它现在对我来说更有意义了）

 Public Enum xlDateAction xlCurrentYear = 1 xlYearToDate = 2 xlAll = 3 End Enum Public Function CellRange(SrcCell As Range, DtRange As xlDateAction, _ Optional YearOverride As Long = 0) As String Application.ScreenUpdating = False If Not IsDate(SrcCell.Value) Then Exit Function If YearOverride = Year(CDate(SrcCell.Value)) Then YearOverride = 0 Dim TargetYear As Long: TargetYear = YearOverride Dim StartCell As Range: Set StartCell = SrcCell Dim EndCell As Range Set EndCell = Columns(SrcCell.Column).Find(What:="", After:=[SrcCell]).Offset(-1, 0) Do Until StartCell.Row = 1 Or Not IsDate(StartCell.Value) Set StartCell = StartCell.Offset(-1, 0) Loop If Not IsDate(StartCell.Value) Then Set StartCell = StartCell.Offset(1, 0) If TargetYear = 0 Then TargetYear = Year(CDate(SrcCell.Value)) If DtRange <> xlAll Then Do Until StartCell.Address = EndCell.Address Or Year(CDate(StartCell.Value)) >= TargetYear If Year(CDate(StartCell.Value)) < TargetYear Then Set StartCell = StartCell.Offset(1, 0) Loop If DtRange = xlYearToDate And Year(CDate(StartCell.Value)) >= TargetYear And _ TargetYear > Year(CDate(SrcCell.Value)) Then Set StartCell = StartCell.Offset(-1, 0) If DtRange = xlCurrentYear Then Do Until EndCell.Address = StartCell.Address Or Year(CDate(EndCell.Value)) <= TargetYear If Year(CDate(EndCell.Value)) > TargetYear Then Set EndCell = EndCell.Offset(-1, 0) Loop ' If target year doesn't exist in dates If Year(CDate(EndCell.Value)) <> TargetYear Then Exit Function Else Set EndCell = SrcCell End If End If CellRange = Range(StartCell, EndCell).Address Application.ScreenUpdating = True End Function 

Answer 4

这大部分可以使用Excel公式轻松完成。 可以使用相同的逻辑来开发VBAfunction

我只注意到你的date不包括本月的第一个到最后一个。 它不应该影响原来的YTD / ALL，但如果你需要指定的第一个和最后一个date，那么这将工作