Избыточность в логике для Excel VBA

Question

Пожалуйста, смотрите прикрепленное изображение -

Мое требование -

• "Если status null и Ref No. not unique, то

проверить значение2. Если значение2 отсутствует, проверьте значение1 и возьмите среднее значение

Пример: Для номера ссылки = 1 рассчитанное значение равно (50 + 10) / 2 = 30 "

• "если status is selected или Ref no is unique, то

копировать из value2, если нет, то копировать из value1

Пример: для ссылки № 3 значение равно 100, а для ссылки № 4 - 20

• Общая стоимость = 100 + 30 + 20 = 150

Моя попытка

For I = 2 To lrow 'sheets all have headers that are 2 rows

        'unique
            If Application.WorksheetFunction.CountIf(ws.Range("A" & fRow, "A" & lrow), ws.Range("A" & I)) = 1 Then
                If (ws.Range("AW" & I) <> "") Then 'AW has value2
                    calc = calc + ws.Range("AW" & I).Value
                Else: calc = calc + ws.Range("AV" & I).Value 'AV has value1
                End If
        'not unique
            Else
                'selected
                If ws.Range("AY" & I) = "Selected" Then 'AY has status (Selected/Null)
                    If (ws.Range("AW" & I) <> "") Then
                        calc = calc + ws.Range("AW" & I).Value
                    Else: calc = calc + ws.Range("AV" & I).Value
                    End If
                'not selected
                Else
                    If (ws.Range("AW" & I) <> "") Then
                        calc1 = calc1 + ws.Range("AW" & I).Value
                    Else: calc1 = calc1 + ws.Range("AV" & I).Value
                    End If
                    calc1 = calc1/Application.WorksheetFunction.CountIf(ws.Range("A" & fRow, "A" & lrow), ws.Range("A" & I))
                End If
            End If

Моя проблема -

• Получение Ref № 3 дважды в моей логике.
• Невозможно рассчитать правильное среднее значение.

Как я могу получить правильный вывод? Спасибо.

Answer 1

Использование оператора SQL для рабочего листа

Если я понимаю ваши требования, они выглядят следующим образом:

• Для каждого Ref no требуется
• среднее значение
  • value2, если оно существует, в противном случае value1
• , где status равно selected или
  • тамэто не status = selected для этого Ref no

Я бы открыл ADODB Recordset для данных со следующим SQL:

SELECT [Ref no], Avg(Iif(value2 IS NOT NULL, value2, value1)) AS Result
FROM Sheet1
LEFT JOIN (
    SELECT DISTINCT [Ref No]
    FROM Sheet1
    WHERE status = "selected"
) t1 ON Sheet1.[Ref no] = t1.[Ref no]
WHERE Sheet1.status="selected" OR t1.[Ref no] IS NULL
GROUP BY [Ref no]

---

Использование вложенных Scripting.Dictionary

Если SQL не ваша вещь, вы можете сделать что-то вроде следующего:

'Define names for the columns; much easier to read row(RefNo) then arr(0)
Const refNo = 1
Const status = 3
Const value1 = 5
Const value2 = 6

'For each RefNo, we have to store 3 pieces of information:
'   whether any of the rows are selected
'   the sum of the values
'   the count of the values
Dim aggregates As New Scripting.Dictionary

Dim arr() As Variant
arr = Sheet1.UsedRange.Value

Dim maxRow As Long
maxRow = UBound(arr, 1)

Dim i As Long
For i = 2 To maxRow 'exclude the column headers in the first row
    Dim row() As Variant
    row = GetRow(arr, i)

    'Get the current value of the row
    Dim currentValue As Integer
    currentValue = row(value1)
    If row(value2) <> Empty Then currentValue = row(value2)

    'Ensures the dictionary always has a record corresponding to the RefNo
    If Not aggregates.Exists(row(refNo)) Then Set aggregates(row(refNo)) = InitDictionary

    Dim hasPreviousSelected As Boolean
    hasPreviousSelected = aggregates(row(refNo))("selected")

    If row(status) = "selected" Then
        If Not hasPreviousSelected Then
            'throw away any previous sum and count; they are from unselected rows
            Set aggregates(row(refNo)) = InitDictionary(True)
        End If
    End If

    'only include currently seleced refNos, or refNos which weren't previously selected,
    If row(status) = "selected" Or Not hasPreviousSelected Then
        aggregates(row(refNo))("sum") = aggregates(row(refNo))("sum") + currentValue
        aggregates(row(refNo))("count") = aggregates(row(refNo))("count") + 1
    End If
Next

Dim key As Variant
For Each key In aggregates
    Debug.Print key, aggregates(key)("sum") / aggregates(key)("count")
Next

со следующими двумя вспомогательными функциями:

Function GetRow(arr() As Variant, rowIndex As Long) As Variant()
    Dim ret() As Variant
    Dim lowerbound As Long, upperbound As Long
    lowerbound = LBound(arr, 2)
    upperbound = UBound(arr, 2)
    ReDim ret(1 To UBound(arr, 2))
    Dim i As Long
    For i = lowerbound To upperbound
        ret(i) = arr(rowIndex, i)
    Next
    GetRow = ret
End Function

Function InitDictionary(Optional selected As Boolean = False) As Scripting.Dictionary
    Set InitDictionary = New Scripting.Dictionary
    InitDictionary.Add "selected", selected
    InitDictionary.Add "sum", 0
    InitDictionary.Add "count", 0
End Function

---

Объяснение SQL

• Для каждого Ref no вы хотите

Группировать записи по Ref no, используя предложение GROUP BY

• среднее

Мы вернем как Ref no, так и average - SELECT [Ref no], Avg(...)

• value2 если существует, в противном случае value1

Iif(value2 IS NOT NULL, value2, value1)

• , где status равно selected или

WHERE Sheet1.status="selected" OR

• для этого нет status = selected Ref no

Мы получаем список (уникальный - DISTINCT) Ref no с status = "selected":

SELECT DISTINCT [Ref No]
FROM Sheet1
WHERE status = "selected"

и даем ему имя (AS t1)так что мы можем ссылаться на него отдельно от основного списка (Sheet1)

Затем мы подключаем или присоединяем (JOIN) этот подсписок к основному списку, где [Ref no] совпадает соба (ON Sheet1.[Ref no] = t1.[Ref no]).

Простой JOIN - это INNER JOIN, где должны совпадать записи на обеих сторонах соединения.В этом случае нам нужны записи в основном списке, которые не соответствуют записям в подсписке.Для просмотра таких записей мы можем использовать LEFT JOIN, который отображает все записи на левой стороне и только те записи на правой стороне, которые совпадают.

Затем мы можем отфильтровать записи, которыесделать матч, используя OR t1.[Ref no] IS NULL.

Answer 2

Должен быть более лаконичный способ, но я думаю, что он делает то, что вы хотите.Он основан на вашем примере, поэтому данные в A1: F6 нужно будет изменить.

Sub x()

Dim v2() As Variant, v1, i As Long, n As Long, d As Double

v1 = Sheet1.Range("A1:F6").Value
ReDim v2(1 To UBound(v1, 1), 1 To 5) 'ref/count/null/value null/value selected

With CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(v1, 1)
        If Not .Exists(v1(i, 1)) Then
            n = n + 1
            v2(n, 1) = v1(i, 1)
            v2(n, 2) = v2(n, 2) + 1
            If v1(i, 3) = "" Then
                v2(n, 3) = v2(n, 3) + 1
                v2(n, 4) = IIf(v1(i, 6) = "", v1(i, 5), v1(i, 6))
            ElseIf v1(i, 3) = "selected" Then
                v2(n, 5) = IIf(v1(i, 6) = "", v1(i, 5), v1(i, 6))
            End If
            .Add v1(i, 1), n
        ElseIf .Exists(v1(i, 1)) Then
            v2(.Item(v1(i, 1)), 2) = v2(.Item(v1(i, 1)), 2) + 1
            If v1(i, 3) = "" Then
                v2(.Item(v1(i, 1)), 3) = v2(.Item(v1(i, 1)), 3) + 1
                If v1(i, 6) = "" Then
                    v2(.Item(v1(i, 1)), 4) = v2(.Item(v1(i, 1)), 4) + v1(i, 5)
                Else
                    v2(.Item(v1(i, 1)), 4) = v2(.Item(v1(i, 1)), 4) + v1(i, 6)
                End If
            Else
                If v1(i, 6) = "" Then
                    v2(.Item(v1(i, 1)), 5) = v2(.Item(v1(i, 1)), 5) + v1(i, 5)
                Else
                    v2(.Item(v1(i, 1)), 5) = v2(.Item(v1(i, 1)), 5) + v1(i, 6)
                End If
            End If
        End If
    Next i
End With

For i = LBound(v2, 1) To UBound(v2, 1)
    If v2(i, 2) > 1 And v2(i, 3) = v2(i, 2) Then
        d = d + v2(i, 4) / v2(i, 2)
    End If
    If v2(i, 2) > 1 And v2(i, 3) < v2(i, 2) Then
        d = d + v2(i, 5) / (v2(i, 2) - v2(i, 3))
    End If
    If v2(i, 2) = 1 And v2(i, 3) = v2(i, 2) Then
        d = d + v2(i, 4) / v2(i, 2)
    End If
Next i

MsgBox "Total = " & d

End Sub