VBA：阵列＆COUNTIF

Question

所有，

我奋力的方法采取在Excel VBA下面的情况：

从我在VBA创建阵列不同片材（4列：键，输入，活动A，活性B的日期），例如日期：

我决定不使用字典，因为阵列（汽车的＃）的大小给出。我也没有使用简单的复制粘贴宏+ countif。 首先，你是否同意VBA中的数组是最好的方法？所以，现在

我奋力最好的办法是什么：

现在我要总结每次活动的结果在表像这样 1）循环在数组中的线条和在循环遍历表中的单元表 2）粘贴值逐一找到对应的汽车 3）复制到一个单独的表，表中的 4）使用COUNTIF ...

能否请您他lp建议？希望问题清楚。

Answer 1

添加一些辅助列（如果你愿意，你可以隐藏这些更高版本）

细胞D2公式是=MONTH(C2)，细胞E2是=YEAR(C2)与同为G和H但在列F

然后在结果表我用公式

=COUNTIFS($B$2:$B$4,$A8, $D$2:$D$4,MONTH(B$7),$E$2:$E$4,YEAR(B$7)) 

对于活动A，活动B可以使用相同的公式（但使用列G和H而不是D和E可以获得您的结果。无需VBA

更新与VBA开发方法

你也可以试试这个方法VBA。您需要注意所有大写的注释并更新输入和输出。代码将采用您的输入数组，并假设第2列后的所有内容都是活动日期。然后它会编译结果并回写到表单。这可以在任何日期范围内工作，因为它会自动检测第一个和最后一个日期（填充一年中的所有日期）以及任何数量的活动。由于它的全部灵活性，这里有很多循环，但是因为它们都在数组/字典中处理（即在内存中），所以不应该出现性能问题。你可以做得更少，但是这应该在几秒钟内处理它，不管数据集大小如何，因此获得努力实在是不值得的。

Option Explicit 
Public Sub GenerateResults() 
    Dim arr As Variant, tmp As Variant, Dates() As Double, Results As Object 
    Dim i As Long, j As Long, StartRow As Long, ResultsSeparator As Long 
    Dim StartYear As Long, EndYear As Long, yr As Long, mo As Long 
    Dim c 

    ' ******UPDATE TO POINT AT YOUR ARRAY****** 
    With Sheet1 
     arr = Range(.Cells(1, 1), .Cells(4, 5)).Value2 
    End With 

    Set Results = CreateObject("Scripting.Dictionary") 

    For j = 3 To UBound(arr, 2) 
     If StartYear < Format(WorksheetFunction.Min(Application.Index(arr, 0, j)), "yyyy") Then 
      StartYear = Format(WorksheetFunction.Min(Application.Index(arr, 0, j)), "yyyy") 
     End If 
     If EndYear < Format(WorksheetFunction.Max(Application.Index(arr, 0, j)), "yyyy") Then 
      EndYear = Format(WorksheetFunction.Max(Application.Index(arr, 0, j)), "yyyy") 
     End If 
    Next j 

    ' 1 to 12 for months in the year, 1 to 2 for each activitity. This could be adapated for more then 12 months 
    ReDim Dates(1 To (1 + EndYear - StartYear) * 12, 1 To UBound(arr, 2) - 2) 

    For i = LBound(arr) To UBound(arr) 
     Set tmp = Nothing 
     ' Add to dictionary if colour not in array 
     If Not Results.exists(arr(i, 2)) Then Results.Add Key:=arr(i, 2), Item:=Dates 
     ' Assign your data to a temporary array so we can change it 
     tmp = Results(arr(i, 2)) 
     ' Update data with activity dates 
     For j = LBound(Dates, 2) To UBound(Dates, 2) 
      tmp(12 * (Year(arr(i, 2 + j)) - StartYear) + Month(arr(i, 2 + j)), j) = tmp(12 * (Year(arr(i, 2 + j)) - StartYear) + Month(arr(i, 2 + j)), j) + 1 
     Next j 
     ' Write data back to dictionary 
     Results(arr(i, 2)) = tmp 
    Next i 

    Application.ScreenUpdating = False 
    ' ******CHANGE TO WHERE YOUR WANT YOUR RESULTS****** 
    ' Starting row of results (change to your output) 
    StartRow = 7 
    ' How many rows do you want between Activity A and B etc. 
    ResultsSeparator = 3 

    With Sheet1 
     For j = LBound(Dates, 2) To UBound(Dates, 2) 
      With .Cells(StartRow + (j - 1) * (ResultsSeparator + Results.Count), 1) 
       .Value2 = UCase("Activity " & Split(.Cells(1, j).Address, "$")(1)) 
       .Font.Bold = True 
      End With 
     Next j 
     StartRow = StartRow + 1 
     For j = LBound(Dates, 1) To UBound(Dates, 1) 
      yr = StartYear + IIf(j Mod 12 = 0, (j/12) - 1, WorksheetFunction.RoundDown(j/12, 0)) 
      mo = IIf(j > 12, j - 12 * IIf(j Mod 12 = 0, (j/12) - 1, WorksheetFunction.RoundDown(j/12, 0)), j) 
      For i = LBound(Dates, 2) To UBound(Dates, 2) 
       With .Cells(StartRow + (i - 1) * (ResultsSeparator + Results.Count), 1 + j) 
        .Value2 = DateSerial(yr, mo, 1) 
        .NumberFormat = "mmm-yy" 
       End With 
      Next i 
     Next j 
     StartRow = StartRow + 1 
     ' Loop through dictionary 
     For Each c In Results.keys 
      ' Write back results for Activity A 
      For j = LBound(Dates, 2) To UBound(Dates, 2) 
       With .Cells(StartRow + (j - 1) * (ResultsSeparator + Results.Count), 1) 
        .Value2 = c 
        Range(.Offset(0, 1), .Offset(0, UBound(Results(c), 1))) = Application.Transpose(Application.Index(Results(c), 0, j)) 
       End With 
      Next j 
      ' Increase Row 
      StartRow = StartRow + 1 
     Next c 
    End With 
    Application.ScreenUpdating = True 
End Sub