组数据和显示平均值( VBA )

Question

我有一个Excel数据集，其中包括有关程序观察的数据，该数据集通常包括每次访问多个观察(每次访问的行数不同)。每行包括网站名称、日期和组成三个域的项的评等。

我需要为这三个领域的每一个按站点/日期分组的方法。例如，2020年6月1日访问的A站点有3次观测，每一次观测对每一项都有评级。这三个观测值中的这些项需要平均为区域1、2和3。在本例中，A是域1，G是域2，L是域3。

下面的第一个图像显示了开始时的样子，第二个图像显示了我希望它看起来是什么样子。

我已经对所有观察到的每个域的平均值进行了编码(下面包含的代码来自实际数据，而不是示例)，但我不知道如何让VBA在每个站点和日期的不同组合的循环中这样做，并将其吐出到一个新的工作表中。如果不清楚，请告诉我！我是VBA的新手。原始数据

​

​

期望结果

​

​

ws2.Range("D1") = Application.WorksheetFunction.Average(ws1.Range("Y6:Y" & lastrow & ",Z6:Z" & lastrow & ",AA6:AA" & lastrow _
    & ",AD6:AD" & lastrow & ",AE6:AE" & lastrow & ",AI6:AI" & lastrow & ",AK6:AK" & lastrow & ",AL6:AL" & lastrow))

    ws2.Range("E1") = Application.WorksheetFunction.Average(ws1.Range("AF6:AF" & lastrow & ",AM6:AM" & lastrow & ",AP6:AP" & lastrow _
    & ",AQ6:AQ" & lastrow & ",AR6:AR" & lastrow & ",AS6:AS" & lastrow & ",AT6:AT" & lastrow & ",AU6:AU" & lastrow))

    ws2.Range("F1") = Application.WorksheetFunction.Average(ws1.Range("AW6:AW" & lastrow & ",AX6:AX" & lastrow & ",AY6:AY" & lastrow))

Answer 1

我会以不同的方式处理这个问题。

它花费大量时间从VBA获得多个工作表访问。在VBA中工作通常要快得多。您可以在一个步骤中将范围读取到数组中，在VBA中进行处理，然后将其写回并在一个步骤中格式化。

例程通常以这种方式以5-10倍的速度运行。

所以

future.

• 为数据源声明工作表，结果

• 将数据读入VBA数组

• 中处理数据，将其组织为字典对象
• 使用一个类(用户定义的对象)为每个Site/Date组合收集数据，包括每个领域的分级集合。

H 110根据第一行的内容分配域名的函数是灵活的，如果在第一行的内容有变化的情况下

• 将输出组织为结果数组
• ，将结果数组写回工作表并格式化它。

一定要阅读代码中的注释

类模块(重命名此cSite)

'Set Reference (on the Tools/References dropdown) to Microsoft Scripting Runtime
'Rename cSite
Option Explicit

Private pSite As String
Private pDt As Date
Private pDomainValue As Long
Private pDomainName As String
Private pDomains As Dictionary

Public Property Get Site() As String
    Site = pSite
End Property
Public Property Let Site(Value As String)
    pSite = Value
End Property


Public Property Get Dt() As Date
    Dt = pDt
End Property
Public Property Let Dt(Value As Date)
    pDt = Value
End Property

Public Property Get DomainValue() As Long
    DomainValue = pDomainValue
End Property
Public Property Let DomainValue(Value As Long)
    pDomainValue = Value
End Property

Public Property Get DomainName() As String
    DomainName = pDomainName
End Property
Public Property Let DomainName(Value As String)
    pDomainName = Value
End Property

Public Property Get Domains() As Dictionary
    Set Domains = pDomains
End Property
Public Function addDomainsItem(domName, domValue)
    Dim v
    If pDomains.Exists(domName) Then
        v = pDomains(domName)
        ReDim Preserve v(UBound(v) + 1)
        v(UBound(v)) = domValue
        pDomains(domName) = v
    Else
        ReDim v(0)
        v(0) = domValue
        pDomains.Add domName, v
    End If
End Function

Public Function avgDomain(domName) As Double
    Dim Num As Double, deNom As Long
    Dim v
    For Each v In Me.Domains(domName)
        Num = Num + v
        deNom = deNom + 1
    Next v
    avgDomain = Num / deNom
End Function

Private Sub Class_Initialize()
    Set pDomains = New Dictionary
        pDomains.CompareMode = TextCompare
End Sub

正则模块

Option Explicit
Sub sites()
    Dim dS As Dictionary, cS As cSite
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim I As Long, J As Long, sKey As String
    Dim v, w
    
'set up the data source and results worksheets, source array, result range
Set wsSrc = ThisWorkbook.Worksheets("Sheet11")

On Error Resume Next
    Set wsRes = ThisWorkbook.Worksheets("Results")
    Select Case Err.Number
        Case 9
            Worksheets.Add after:=wsSrc
            ActiveSheet.Name = "Results"
            Set wsRes = Worksheets("Results")
        Case Is <> 0
            MsgBox "Error: " & Err.Number & vbLf & Err.Description
            Exit Sub
    End Select
On Error GoTo 0

Set rRes = wsRes.Cells(1, 1)
With wsSrc
    'last row
    I = .Cells(.Rows.Count, 1).End(xlUp).Row
    
    'last column
    J = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
    vSrc = .Range(.Cells(1, 1), .Cells(I, J))
End With

'read and organize the data into a dictionary
Set dS = New Dictionary

For I = 2 To UBound(vSrc, 1)
    sKey = vSrc(I, 1) & "|" & vSrc(I, 2)
    Set cS = New cSite
    With cS
        If Not dS.Exists(sKey) Then
            .Site = vSrc(I, 1)
            .Dt = vSrc(I, 2)
            For J = 3 To UBound(vSrc, 2)
                .DomainName = myDomain(CStr(vSrc(1, J)))
                .DomainValue = vSrc(I, J)
                .addDomainsItem .DomainName, .DomainValue
            Next J
            dS.Add KEY:=sKey, Item:=cS
        Else
            With dS(sKey)
                For J = 3 To UBound(vSrc, 2)
                    .DomainName = myDomain(CStr(vSrc(1, J)))
                    .DomainValue = vSrc(I, J)
                    .addDomainsItem .DomainName, .DomainValue
                Next J
            End With
        End If
    End With
Next I

For Each v In dS.Keys
    For Each w In dS(v).Domains
        Debug.Print v, w, dS(v).avgDomain(w)
    Next w
Next v

'create output array
ReDim vRes(0 To dS.Count, 1 To 5)

'Header Rows
vRes(0, 1) = "Site"
vRes(0, 2) = "Date"
vRes(0, 3) = myDomain("a")
vRes(0, 4) = myDomain("g")
vRes(0, 5) = myDomain("l")

'Data
I = 0
For Each v In dS.Keys
    I = I + 1
    With dS(v)
        vRes(I, 1) = .Site
        vRes(I, 2) = .Dt
        J = 2
        For Each w In .Domains
            J = J + 1
            vRes(I, J) = .avgDomain(w)
        Next w
    End With
Next v

'write the results
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .Columns(2).NumberFormat = "m/d/yyyy"
    With .Range(.Cells(2, 3), .Cells(.Rows.Count, .Columns.Count))
        .NumberFormat = "0.00"
    End With
    .Style = "Output" 'might need to change this if not English language
    .Rows(1).HorizontalAlignment = xlCenter
    .EntireColumn.AutoFit
End With
    
End Sub

Function myDomain(S As String) As String
    Select Case S
        Case "a" To "f"
            myDomain = "Domain 1"
        Case "g" To "k"
            myDomain = "Domain 2"
        Case "l" To "r"
            myDomain = "Domain 3"
    End Select
End Function

原始数据

​

​

结果

​

​