VBA - 计算特定日期范围内的值 [英] VBA - Count Values within a certain Date Range

问题描述

首先，让我告诉你我想要实现的脚本。我需要一个脚本来计算日期范围内的值3个月，我有一个源文件，其中包含3个月的数据，现在如果数据在数月内，我需要按月计算数据（3 ）将其标记为所选..（每月至少一个值（最多3个））

样本：

 `头文件A |标题B |标题C | 
 white | 1/1/2016 | | 
 white | 2/2/2016 | | 
 white | 3/3/2016 | | 
黑色| 1/1/2016 | | 
黑色| 2/2/2016 | | 
 gray | 3/3/2016 | | 
 gray | 3/3/2016 | | 
 gray | 4/4/2016 | | 
 brown | 4/4/2016 | | 
 brown | 4/4/2016 | | 
 brown | 5/5/2016 | | 
 brown | 6/6/2016 | | 
  

样本输出：

 `标题A |标题B |标题C | 
 white | 1/1/2016 | | 
 white | 2/2/2016 | | 
 white | 3/3/2016 | selected | 
黑色| 1/1/2016 | | 
黑色| 2/2/2016 | | 
 gray | 3/3/2016 | | 
 gray | 3/3/2016 | | 
 gray | 4/4/2016 | | 
 brown | 4/4/2016 | | 
 brown | 4/4/2016 | | 
 brown | 5/5/2016 | | 
 brown | 6/6/2016 | selected | 
  

在上面的示例中。数据 white 已被标记为选择，因为它符合要求的条件，假设需要的标准是每月至少一种颜色我们有3个月的数据，所以每月需要计算1种颜色。其他颜色在ex。没有符合标准，如颜色黑色它只有 2个月的数据我们需要的是$ code> 3个月。颜色灰色有3个数据，如果你认为只会返回2个月，因为一个月有2个数据。颜色为棕色符合标准，因为有一个数据 3个月一个月内的重复值很好，只要每个月都有一个数据（3）for ..

现在这是我的代码：

 '将所有行重复3个月检查他们的日期，然后创建一个任意的列（lastcolumn +1）来存储月份值
对于rownum = 2 To lastrow_masterfile 
 
 varDatesValue = masterfileWKsht.Range（B& rownum）。值
 masterfileWKsht.Range（D& rownum）.Value = Month（varDatesValue）
 
下一个
 
 
'颜色的列范围
设置myRangeColor = ThisWorkbook.Sheets（masterfile）。范围（A2：A& lastrow_masterfile）
 
'（任意列）的列范围monthvalue 
设置myRangeMonthValue = ThisWorkbook.Sheets（masterfile）。Range（D2：D& lastrow_masterfile）
 
 
'每周数据循环
对于rownum_weekly = startingrow_of_weekly To lastRow 
 varColors = master fileWKsht.Range（B& rownue_weekly）.Value 
 varCOMMonth = Month（masterfileWKsht.Range（A& rownum_weekly）.Value）
 
'CountIfs 1：
 varMonth1 = WorksheetFunction.CountIfs（myRangeColor， varColor，myRangeMonthValue，varDatesValue）
 
'CountIfs 2：
'每行的varDates的月值-1上个月的值（这是存储monthvalue的新列的范围）
 varMonth2 = WorksheetFunction.CountIfs（myRangeColor，varColor，myRangeMonthValue，varDatesValue  -  1）
 
 
'CountIfs 3：
'每行varDates的月值-2 2个月前范围是存储monthvalue的新列）
 varMOnth3 = WorksheetFunction.CountIfs（myRangeColor，varColor，myRangeMonthValue，varDatesValue  -  2）
 
 
'如果值为3 countifs是至少1，然后将其标记为选定的
如果varMonth1> = 1和varMonth2> = 1和varMOnth3> = 1然后
'在此插入代码（我仍然不知道如何写代码这里）
结束如果
 
下一个
  

请帮助我这个....

解决方案

公式解决方案

虽然我承认您正在寻找一个VBA解决方案（有一个很好的理由），我想指出，您可以通过使用公式来解决这个问题。您可以使用以下数组公式获得您要查找的结果：

{= IF（SUM（IF（FREQUENCY（（$ A $ 2：$ A $ 13 = A2）*（MONTH（$ B $ 2：$ B $ 13）），（$ A $ 2：$ A $ 13 = A2）*（MONTH（$ B $ 2：$ B $ 13）））大于0 ，1））> 3，Selected，）}

这将返回 code>如果在至少三个不同的月份中找到颜色。

要使用此选项，请在单元格 C2 ，通过按 CTRL + SHIFT + ENTER （由于它是一个数组公式）并沿着方向拖动公式的数据。

VBA +公式解决方案

如您所言，您需要在生成的报告，您可以简单地使用VBA在表格中键入公式：

  Sub AddFormula（）
 Dim MstrSht作为工作表
 Dim ColorRng As Range 
 Dim DateRng As Range 
 Dim i As Integer 
 
设置MstrSht = ThisWorkbook.Sheets（masterfile）
 
'设置颜色范围和日期范围
设置ColorRng = MstrSht.Range（A2：A& MstrSht.Cells（Rows.Count，1）.End（xlUp）.Row）
设置DateRng = MstrSht.Range（B2：B& MstrSht.Cells（Rows.Count，1）.End（xlUp ）.Row）
 
'为列C中的单元格添加公式
对于i = 2到MstrSht.Cells（Rows.Count，1）.End（xlUp）.Row 
 MstrSht.Cells（i，3）.FormulaArray == IF（SUM（IF（FREQUENCY（（& ColorRng.Address&= A& i&）*（MONTH（&地址&）），（& _ 
 ColorRng.Address&= A& i&）*（MONTH（& DateRng.Address）））> 0,1））> 3，Selected，）
 Next i 
 End Sub 
  

仅限VBA的解决方案

完全忽略原始代码时，您可能会受到此采访的启发在一个仅限VBA的解决方案中

  Sub MarkColors（）
 Dim MstrSht As Worksheet 
 Dim DataArr As Variant 
 Dim ColorArr As Variant 
 Dim MonthCol As Collection 
 Dim CloseToDat e As Date 
 Dim MaxDate As Date 
 Dim c As Long 
 Dim i As Long 
 
设置MstrSht = ThisWorkbook.Sheets（masterfile）
 
'定义日期
 CloseToDate = DateSerial（2016,6,6）'< ~~定义日期
 
'将数据加载到数组
 DataArr = MstrSht.Range （A2：C& MstrSht.Cells（Rows.Count，1）.End（xlUp）.Row）
 
'查找不同的颜色
 ColorArr = ReturnDistinct（MstrSht.Range（A2：A& MstrSht .Cells（Rows.Count，1）.End（xlUp）.Row））
 
'删除数组第三列中的任何值
对于i = LBound（DataArr，1）到UBound （DataArr，1）
 DataArr（i，3）=
 Next i 
 
'循环每个颜色
对于c = LBound（ColorArr）到UBound ColorArr）
设置MonthCol =新集合
 MaxDate = 0 
对于i = LBound（DataArr，1）To UBound（DataArr，1）
如果DataArr（i，1）= ColorArr（c）然后
'将颜色的月份加载到一个集合
 On Error Resume Next 
 MonthCol.Add Month（DataArr（i，2）），CStr（Month（DataArr（i， 2）））
 On Error GoTo 0 
'查找最大日期
如果DataArr（i，2）< = CloseToDate Then 
 MaxDate = Applicati on.WorksheetFunction.Max（MaxDate，DataArr（i，2））
 End If 
 End If 
 Next i 
 
'如果颜色被发现在三个或更多单独的月份，那么最接近CloseToDate的日期的行被标记为
如果MonthCol.Count> 2然后
对于i = LBound（DataArr，1）To UBound（DataArr，1）
如果DataArr（i，1）= ColorArr（c）和DataArr（i，2）= MaxDate Then 
 DataArr（i，3）=Selected
 End If 
 Next if 
 End If 
 Next c 
 
'打印结果到表格
 MstrSht.Range（A2：C& MstrSht.Cells（Rows.Count，1）.End（xlUp）.Row）= DataArr 
 End Sub 
 
'返回具有不同值的数组
函数ReturnDistinct（InpRng As Range）As Variant 
 Dim Cell As Range 
 Dim i As Integer 
 Dim DistCol As New Collection 
 Dim DistArr（） 
 
'将所有值添加到集合
对于InpRng中的每个单元格
错误恢复下一步
 DistCol.Add Cell.Value，CStr（Cell.Value）
 On Error GoTo 0 
下一个单元格
 
'将数组写入数组
 ReDim DistArr（1 To DistCol.Count）
对于i = 1 To DistCol.Count步骤1 
 DistArr（i）= DistCol.Item（i）
 Next i 
 
 ReturnDistinct = DistArr 
结束函数
  

请注意，我不确定您想要成为选定日期的日期。因此，我添加了变量 CloseToDate ，代码将选择该行的日期最接近（但较小）比此特定日期

First, Let me tell you the script that i want to achieve. I need a script that will count the values within a date range the range of date is 3 months, I have a source file which contains 3 months of data now i need to count the data by months if the data is within the months(3) tagged it as selected..(at least one value per month(up to 3))

Sample:

`Header A|Header B  |Header C|
   white | 1/1/2016 |        |
   white | 2/2/2016 |        |
   white | 3/3/2016 |        |
   black | 1/1/2016 |        |
   black | 2/2/2016 |        |
   grey  | 3/3/2016 |        |
   grey  | 3/3/2016 |        |
   grey  | 4/4/2016 |        |
   brown | 4/4/2016 |        |
   brown | 4/4/2016 |        |
   brown | 5/5/2016 |        |
   brown | 6/6/2016 |        |

Sample Output:

`Header A|Header B  |Header C|
   white | 1/1/2016 |        |
   white | 2/2/2016 |        |
   white | 3/3/2016 |selected|
   black | 1/1/2016 |        |
   black | 2/2/2016 |        |
   grey  | 3/3/2016 |        |
   grey  | 3/3/2016 |        |
   grey  | 4/4/2016 |        |
   brown | 4/4/2016 |        |
   brown | 4/4/2016 |        |
   brown | 5/5/2016 |        |
   brown | 6/6/2016 |selected|

In the sample above. The data white has been tagged as selected because it meets the required criteria, let's say the criteria needed is "at least one color per month" we have 3 month of data so it needs to count 1 color per month. The other color in the ex. didnt meet the criteria like the color black it only have data for 2 months what we need is for 3 months. The color grey have 3 data if you count it will only return 2 months because there is 2 data in a month. The color brown meets the criteria because there is a data for 3 months duplicate value in a month is fine as long it has a data every months(3) for..

Now here's my code:

'iterate all rows for 3 months to check their dates then create an arbitrary column(lastcolumn +1) to store the month value
For rownum = 2 To lastrow_masterfile

     varDatesValue = masterfileWKsht.Range("B" & rownum).Value
     masterfileWKsht.Range("D" & rownum).Value = Month(varDatesValue)

Next


'column range for color
Set myRangeColor = ThisWorkbook.Sheets("masterfile").Range("A2:A" & lastrow_masterfile)

'column range for (arbitrary column)monthvalue
Set myRangeMonthValue = ThisWorkbook.Sheets("masterfile").Range("D2:D" & lastrow_masterfile)


'loop for weekly data
For rownum_weekly = startingrow_of_weekly To lastRow
    varColors = masterfileWKsht.Range("B" & rownum_weekly).Value
    varCOMMonth = Month(masterfileWKsht.Range("A" & rownum_weekly).Value)

'CountIfs 1:
    varMonth1 = WorksheetFunction.CountIfs(myRangeColor, varColor, myRangeMonthValue, varDatesValue)

'CountIfs 2:
   'month value of varDates per row -1 for previous month(range of this is the new column which store the monthvalue)
    varMonth2 = WorksheetFunction.CountIfs(myRangeColor, varColor, myRangeMonthValue, varDatesValue - 1)


'CountIfs 3:
  'month value of varDates per row -2 for 2months ago(range of this is the new column which store the monthvalue)
    varMOnth3 = WorksheetFunction.CountIfs(myRangeColor, varColor, myRangeMonthValue, varDatesValue - 2)


    'if value of the 3 countifs is atleast 1 then tagged it as selected
    If varMonth1 >= 1 And varMonth2 >= 1 And varMOnth3 >= 1 Then
         'insert code here(i still dont khow how to write code here)
    End If

Next

please help me about this....

解决方案

Formula Solution
Although I acknowledge that you are looking for a VBA solution to this (perhapse for a good reason), I want to point out that you can solve this by using formulas. You could get the result you are looking for by using an array formula like:

{=IF(SUM(IF(FREQUENCY(($A$2:$A$13=A2)*(MONTH($B$2:$B$13)),($A$2:$A$13=A2)*(MONTH($B$2:$B$13)))>0,1))>3,"Selected","")}

This will return Selected if the color is found in at least three different months.

To use this, type the formula in cell C2, commit by pressing CTRL+SHIFT+ENTER (since it is an array formula) and drag the formula down along side of your data.

VBA+Formula Solution
As you commented that you need this applied in a generated report, you could simply use VBA to type the formula into the sheet:

Sub AddFormula()
    Dim MstrSht As Worksheet
    Dim ColorRng As Range
    Dim DateRng As Range
    Dim i As Integer

    Set MstrSht = ThisWorkbook.Sheets("masterfile")

    'Set Color Range and Date Range
    Set ColorRng = MstrSht.Range("A2:A" & MstrSht.Cells(Rows.Count, 1).End(xlUp).Row)
    Set DateRng = MstrSht.Range("B2:B" & MstrSht.Cells(Rows.Count, 1).End(xlUp).Row)

    'Add Formula to cells in column C
    For i = 2 To MstrSht.Cells(Rows.Count, 1).End(xlUp).Row
        MstrSht.Cells(i, 3).FormulaArray = "=IF(SUM(IF(FREQUENCY((" & ColorRng.Address & "=A" & i & " )*(MONTH(" & DateRng.Address & ")),(" & _
            ColorRng.Address & "=A" & i & ")*(MONTH(" & DateRng.Address & ")))>0,1))>3,""Selected"","""")"
    Next i
End Sub

VBA-Only Solution
While completely disregarding your original code, you may be able to get inspired by this take on a VBA-only solution

Sub MarkColors()
    Dim MstrSht As Worksheet
    Dim DataArr As Variant
    Dim ColorArr As Variant
    Dim MonthCol As Collection
    Dim CloseToDate As Date
    Dim MaxDate As Date
    Dim c As Long
    Dim i As Long

    Set MstrSht = ThisWorkbook.Sheets("masterfile")

    'Define date
    CloseToDate = DateSerial(2016, 6, 6) '<~~ Define date

    'Load Data into Array
    DataArr = MstrSht.Range("A2:C" & MstrSht.Cells(Rows.Count, 1).End(xlUp).Row)

    'Find distinct colors
    ColorArr = ReturnDistinct(MstrSht.Range("A2:A" & MstrSht.Cells(Rows.Count, 1).End(xlUp).Row))

    'Remove any values in the arrays third column
    For i = LBound(DataArr, 1) To UBound(DataArr, 1)
        DataArr(i, 3) = ""
    Next i

    'Loop Each Color
    For c = LBound(ColorArr) To UBound(ColorArr)
        Set MonthCol = New Collection
        MaxDate = 0
        For i = LBound(DataArr, 1) To UBound(DataArr, 1)
            If DataArr(i, 1) = ColorArr(c) Then
                'Load the colors months into a collection
                On Error Resume Next
                MonthCol.Add Month(DataArr(i, 2)), CStr(Month(DataArr(i, 2)))
                On Error GoTo 0
                'Find Max Date
                If DataArr(i, 2) <= CloseToDate Then
                    MaxDate = Application.WorksheetFunction.Max(MaxDate, DataArr(i, 2))
                End If
            End If
        Next i

        'If the color were found in three or more seperate months then the row with date closest to CloseToDate gets flagged
        If MonthCol.Count > 2 Then
            For i = LBound(DataArr, 1) To UBound(DataArr, 1)
                If DataArr(i, 1) = ColorArr(c) And DataArr(i, 2) = MaxDate Then
                    DataArr(i, 3) = "Selected"
                End If
            Next i
        End If
    Next c

    'Print results to sheet
    MstrSht.Range("A2:C" & MstrSht.Cells(Rows.Count, 1).End(xlUp).Row) = DataArr
End Sub

'Return Array With Distinct Values
Function ReturnDistinct(InpRng As Range) As Variant
    Dim Cell As Range
    Dim i As Integer
    Dim DistCol As New Collection
    Dim DistArr()

    'Add all values to collection
    For Each Cell In InpRng
        On Error Resume Next
        DistCol.Add Cell.Value, CStr(Cell.Value)
        On Error GoTo 0
    Next Cell

    'Write collection to array
    ReDim DistArr(1 To DistCol.Count)
    For i = 1 To DistCol.Count Step 1
        DistArr(i) = DistCol.Item(i)
    Next i

    ReturnDistinct = DistArr
End Function

Note, that I am unsure about exactly which date you want to be the "selected" date. Thus, I have added the variable CloseToDate, and the code will "select" the row with the date that is closest (but smaller) than this particular date.

这篇关于VBA - 计算特定日期范围内的值的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！