Получить среднее за неделю значение макроса за день

Question

Занято прохождением макро-курса. Как лучше всего справиться с такой проблемой:

a) Ежедневно в таблицу данных вставляется ежедневное значение

b) Неделя длится с понедельника по воскресенье.

c) В любой момент, если макрос запущен, необходимо вывести среднее значение за неделю на отдельном листе. Поэтому, если сегодня четверг, необходимо получить среднее значение с понедельника по среду.

d) Я приложил пример набора данных, но я расширю его до реальных данных позже, когда выясню, какие инструменты будет уместно.

введите описание изображения здесь

Answer 1

Было бы неплохо использовать adodb. Заголовок: MYDay, количество.

Sub exeSQLgetdata()
 
    Dim Rs As Object
    Dim strConn As String
    Dim i As Integer
    Dim Fn As String
    Dim Ws As Worksheet, toWs As Worksheet
    Dim strSQL As String, sWsname As String
    Dim vDB As Variant
    Dim rngWeek As Range
    Dim st, et
    
    st = Timer
    
    Set Ws = Sheets(1)  '<~~ data Sheet
    Set toWs = Sheets(2) '<~~ Report Sheet
    
    sWsname = "[" & Ws.Name & "$]"
    
    Fn = ThisWorkbook.Path & "\" & "Database9.accdb"
    
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & ThisWorkbook.FullName & ";" & _
            "Extended Properties=Excel 12.0;"
 
    Set Rs = CreateObject("ADODB.Recordset")
    
    strSQL = "SELECT DATEPART('W', MYDay, 1) as WeekDay, AVG(Quantity) AS AVERAGE FROM " & sWsname & " GROUP BY DATEPART('W', MYDay,1) "
    
    Rs.Open strSQL, strConn
    
    If Not Rs.EOF Then
        With toWs
            For i = 0 To Rs.Fields.Count - 1
                .Cells(1, i + 1) = Rs.Fields(i).Name
            Next i
            .UsedRange.Offset(1).Clear
            .Range("a2").CopyFromRecordset Rs
            Set rngWeek = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
            vDB = rngWeek
            For i = 1 To UBound(vDB, 1)
                vDB(i, 1) = Format(vDB(i, 1), "ddd", vbSunday)
            Next i
            rngWeek = vDB
        End With
    End If
    Rs.Close
    Set Rs = Nothing
    et = Timer
    
    Debug.Print "Get Data time : " & et - st & " seconds" 
End Sub

Приведенный выше код усреднен по дням недели. Среднее значение за неделю следующее.

Sub exeSQLgetdata2()
 
    Dim Rs As Object
    Dim strConn As String
    Dim i As Integer
    Dim Fn As String
    Dim Ws As Worksheet, toWs As Worksheet
    Dim strSQL As String, sWsname As String
    Dim vDB As Variant
    Dim rngWeek As Range
    Dim st, et
    
    st = Timer
    
    Set Ws = Sheets(1)  '<~~ data Sheet
    Set toWs = Sheets(2) '<~~ Report Sheet
    
    sWsname = "[" & Ws.Name & "$]"
    
    Fn = ThisWorkbook.Path & "\" & "Database9.accdb"
    
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & ThisWorkbook.FullName & ";" & _
            "Extended Properties=Excel 12.0;"
 
    Set Rs = CreateObject("ADODB.Recordset")
    '2 : Monday to Sunday,  1: Sunday to Saturday
    strSQL = "SELECT DATEPART('WW', MYDay, 2) as WeekNum, AVG(Quantity) AS AVERAGE FROM " & sWsname & " GROUP BY DATEPART('WW', MYDay,2) "
    
    Rs.Open strSQL, strConn
    
    If Not Rs.EOF Then
        With toWs
            For i = 0 To Rs.Fields.Count - 1
                .Cells(1, i + 1) = Rs.Fields(i).Name
            Next i
            .UsedRange.Offset(1).Clear
            .Range("a2").CopyFromRecordset Rs
'            Set rngWeek = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
'            vDB = rngWeek
'            For i = 1 To UBound(vDB, 1)
'                vDB(i, 1) = Format(vDB(i, 1), "ddd", vbSunday)
'            Next i
'            rngWeek = vDB
        End With
    End If
    Rs.Close
    Set Rs = Nothing
    et = Timer
    
    Debug.Print "Get Data time : " & et - st & " seconds" 
End Sub

Лист технических данных (1) изображение

Resut Sheet sheets(2) image

введите описание изображения здесь

Answer 2

Я использую следующий код VBA, который, я думаю, вам подойдет

Он покажет вам на другом листе среднее значение для дат в течение текущей недели. Я обновил функцию месяца, как вы просили

Sub Test()
Dim LR As Integer

LR = Cells(Rows.Count, "A").End(xlUp).Row
Range("E1").Value = "=Weeknum(Today())"
Range("F1").Value = "=Month(Today())"

For i = 1 To LR
    Range("C" & i).Value = WorksheetFunction.WeekNum(Range("A" & i))
    Range("D" & i).Formula = "=Month(A" & i & ")"
Next i

Worksheets("Planilha2").Range("A1").Value = WorksheetFunction.AverageIf(Worksheets("Planilha1").Range("C:C"), Worksheets("Planilha1").Range("E1").Value, Worksheets("Planilha1").Range("B:B"))
Worksheets("Planilha2").Range("B1").Value = WorksheetFunction.AverageIf(Worksheets("Planilha1").Range("D:D"), Worksheets("Planilha1").Range("F1").Value, Worksheets("Planilha1").Range("B:B"))

End Sub