Access 連結 Excel : 三萬筆資料用連結即可,匯入可能很耗時;下次使用時只要覆蓋 Excel

來源 Excel

讀取 Excel

產出結果

SQL 指令

SELECT Amount.A,
Amount.B, 
IIF(X.Counter <> null ,Round(X.DX / X.Counter,0),0) AS C, 
Amount.D, 
IIF(X.Counter <> null,Round(X.FX / X.Counter,0),0) AS E, 
Amount.F,
X.Counter
FROM 工作表1 AS Amount LEFT JOIN (Select Amount.A,Amount.B,Count(Amount.B) As Counter,P.DX,P.FX
  From 工作表1 As Amount
  Inner Join (
    Select A,Min(B) As BX,Max(D) As DX,Max(F) As FX
    From 工作表1 As Amount
    Group By A  
  ) As P On P.A = Amount.A And P.BX = Amount.B
  Group By Amount.A,Amount.B,P.DX,P.FX
)  AS X ON (X.B = Amount.B) AND (X.A = Amount.A);

排序欄位取值 => 每個 ID 群組排序欄位取最小值,不一定都是 9

菩薩慈悲：做好收工。請　菩薩垂慈驗收。感恩感恩　南無阿彌陀佛

Option Explicit

Enum ColumnName
    ID = 1
    Sort = 2
    splitAmount = 3
    NoSplitAamount = 4
    splitInterest = 5
    NoSplitInterest = 6
End Enum


Sub AverageShareAmountInterest()
    Dim ws As Worksheet, c As Range, r As Long, rc As Long, keyID, itemCell, arr
'    Dim dictIDdict As New Scripting.Dictionary
'    Dim dictSortCells As New Scripting.Dictionary
'    Dim dictNoSplitAamount As New Scripting.Dictionary, dictNoSplitInterest As New Scripting.Dictionary
    Dim dictIDdict As Object, dictSortCells As Object, dictNoSplitAamount As Object, dictNoSplitInterest As Object
    Dim clnCells As New VBA.Collection
    Set dictIDdict = CreateObject("Scripting.Dictionary")
    Set dictSortCells = CreateObject("Scripting.Dictionary")
    Set dictNoSplitAamount = CreateObject("Scripting.Dictionary")
    Set dictNoSplitInterest = CreateObject("Scripting.Dictionary")
    
    Dim splitAmount As Long, splitInterest As Long
    
    Set ws = ActiveSheet
    rc = ws.UsedRange.Rows.Count
    For r = 2 To rc
        
        If dictIDdict.Exists(Cells(r, ColumnName.ID).Value) Then
            Set dictSortCells = dictIDdict(Cells(r, ColumnName.ID).Value)
            If dictSortCells.Exists(Cells(r, ColumnName.Sort).Value) Then
                Set clnCells = dictSortCells(Cells(r, ColumnName.Sort).Value)
                clnCells.Add Cells(r, ColumnName.splitAmount)
                
            Else
                Set clnCells = Nothing
                clnCells.Add Cells(r, ColumnName.splitAmount)
                dictSortCells.Add Cells(r, ColumnName.Sort).Value, clnCells
            End If
            
        Else
            Set dictSortCells = CreateObject("Scripting.Dictionary")
            Set clnCells = Nothing
            clnCells.Add Cells(r, ColumnName.splitAmount)
            dictSortCells.Add Cells(r, ColumnName.Sort).Value, clnCells
            dictIDdict.Add Cells(r, ColumnName.ID).Value, dictSortCells
        End If
        
        If Cells(r, ColumnName.NoSplitAamount).Value <> "" Then
            dictNoSplitAamount(Cells(r, ColumnName.ID).Value) = Cells(r, ColumnName.NoSplitAamount).Value
        End If
        If Cells(r, ColumnName.NoSplitInterest).Value <> "" Then
            dictNoSplitInterest(Cells(r, ColumnName.ID).Value) = Cells(r, ColumnName.NoSplitInterest).Value
        End If
        
    Next r
    
    
    Randomize
    For Each keyID In dictIDdict.Keys
        r = RGB(Int(Rnd * 192), Int(Rnd * 192), Int(Rnd * 192))
        'r = RGB(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))
        Set dictSortCells = dictIDdict(keyID)
        arr = dictSortCells.Keys
        Call QuickSortArray(arr, LBound(arr), UBound(arr))
        arr = arr(0) '取得最小值（排序最好的）
        splitAmount = dictNoSplitAamount(keyID) / dictSortCells(arr).Count
        splitInterest = dictNoSplitInterest(keyID) / dictSortCells(arr).Count
        For Each itemCell In dictSortCells(arr)
            Cells(itemCell.Row, ColumnName.Sort).Font.Color = RGB(255, 0, 0)
            Range(Cells(itemCell.Row, ColumnName.ID), Cells(itemCell.Row, ColumnName.NoSplitInterest)).Interior.Color = r
            
            If itemCell.NumberFormat <> "#,###" Then itemCell.NumberFormat = "#,###"
            itemCell.Value = splitAmount
            If Cells(itemCell.Row, ColumnName.splitInterest).NumberFormat <> "#,###" Then Cells(itemCell.Row, ColumnName.splitInterest).NumberFormat = "#,###"
            Cells(itemCell.Row, ColumnName.splitInterest).Value = splitInterest
        Next itemCell
    Next keyID
End Sub


Private Sub QuickSortArray(ByRef arr As Variant, ByVal left As Long, ByVal right As Long)
    Dim i As Long
    Dim j As Long
    Dim pivot As Variant
    Dim temp As Variant
    
    i = left
    j = right
    pivot = arr((left + right) \ 2)
    
    While i <= j
        While arr(i) < pivot And i < right
            i = i + 1
        Wend
        
        While pivot < arr(j) And j > left
            j = j - 1
        Wend
        
        If i <= j Then
            temp = arr(i)
            arr(i) = arr(j)
            arr(j) = temp
            i = i + 1
            j = j - 1
        End If
    Wend
    
    If left < j Then
        Call QuickSortArray(arr, left, j)
    End If
    
    If i < right Then
        Call QuickSortArray(arr, i, right)
    End If
End Sub

假設
1.工作表中已設定總金額及總利息

1.Before

2.Execute VBA

3.After

C2:
=IF(B2=9,AVERAGEIFS(D:D,A:A,A2,B:B,B2)/COUNTIFS(A:A,A2,B:B,B2),0)
向下複製到C3:C19儲存格。
E2:
=IF(B2=9,AVERAGEIFS(F:F,A:A,A2,B:B,B2)/COUNTIFS(A:A,A2,B:B,B2),0)
向下複製到E3:E19儲存格。