🚀 go-pugleaf

Dzień dobry,
Czy można jakoś przyspieszyć poniższe funkcje liczenia mediany?


Function DMediana(sql, ParamArray args())
  Dim db As Database
  Dim qr As QueryDef
  Dim rs As Recordset
  Dim pr As Parameter


  Dim i As Long, k As Long


  Set db = DBEngine(0)(0)
  Set qr = db.CreateQueryDef("", sql)


  For i = 0 To UBound(args)
    Set pr = qr.Parameters(i)
    pr.Value = args(i)
  Next


  Set rs = qr.OpenRecordset
  With rs
    If Not (.BOF And .EOF) Then
      .MoveLast
      k = .RecordCount
      If k Mod 2 = 1 Then
        .MoveFirst
        .Move (k - 1) / 2
        DMediana = .Fields(0)
      Else
        .MoveFirst
        .Move k / 2 - 1
        DMediana = .Fields(0)
        .MoveNext
        DMediana = (DMediana + .Fields(0)) / 2
      End If


    Else
      DMediana = Null
    End If
  End With


End Function




Sub CMEDIA()
On Error GoTo ErrMsg

Dim strSQLDM As String
Dim strFile As String
Dim strFtext As String
Dim db As Database
Dim rs As DAO.Recordset
Dim fs As Object
Dim csvFMedia As Object
Dim i As Integer
Dim v As Variant

Dim sUser As String
sUser = VBGetUserName()

Set db = CurrentDb

strSQLDM = "SELECT t.PRODUKT, DMEDIANA(""SELECT MM FROM qryMEDIANA WHERE PRODUKT = [p1] ORDER BY MM"", " & _
"t.PRODUKT ) AS MEDIANA FROM qryMEDIANA AS t GROUP BY t.PRODUKT;"

'strSQLDM = "SELECT t.PRODUKT, DMEDIANA(""SELECT MM FROM PRECYZJA3 WHERE PRODUKT = [p1] ORDER BY MM"", " & _
'"t.PRODUKT ) AS MEDIANA FROM PRECYZJA3 AS t GROUP BY t.PRODUKT;"

DoCmd.Hourglass (True)

Set rs = db.OpenRecordset(strSQLDM)

If rs.BOF Or rs.EOF Then
Exit Sub
Else
    
    v = SysCmd(acSysCmdInitMeter, "Generowanie mediany:", rs.RecordCount)
    i = 1

    rs.MoveFirst
    
    Do Until rs.EOF
        v = SysCmd(acSysCmdUpdateMeter, i)
        i = i + 1
   
        If strFtext = "" Then
        strFtext = "Produkt;Mediana"
        strFtext = strFtext & vbCrLf & "'" & rs.Fields("PRODUKT") & ";" & rs.Fields("MEDIANA")
        Else
        strFtext = strFtext & vbCrLf & "'" & rs.Fields("PRODUKT") & ";" & rs.Fields("MEDIANA")
        End If
        
        rs.MoveNext
    Loop


pozdrawiam
MF