Функция для определения смены:
Function GetShiftForDatetime(targetDate As Date) As String
Dim baseDate As Date
Dim daysDiff As Long
Dim hour As Integer
baseDate = DateSerial(2024, 11, 1) ' Опорная дата
daysDiff = DateDiff("d", baseDate, targetDate)
hour = Hour(targetDate)
' Начальное состояние смен
Dim initialState As Object
Set initialState = CreateObject("Scripting.Dictionary")
initialState.Add "Г", 0 ' Дневная смена
initialState.Add "А", 1 ' Ночная смена 2
initialState.Add "Б", 2 ' Отсыпной (ночная 1)
initialState.Add "В", 3 ' Выходной
Dim shiftLetter As Variant
For Each shiftLetter In initialState.Keys
Dim currentPos As Long
currentPos = (initialState(shiftLetter) + daysDiff) Mod 4
If currentPos = 0 And (hour >= 8 And hour < 20) Then ' Дневная смена
GetShiftForDatetime = shiftLetter
Exit Function
ElseIf currentPos = 1 And (hour >= 20 And hour <= 23) Then ' Ночная смена 2
GetShiftForDatetime = shiftLetter
Exit Function
ElseIf currentPos = 2 And (hour >= 0 And hour < 8) Then ' Отсыпной
GetShiftForDatetime = shiftLetter
Exit Function
End If
Next
GetShiftForDatetime = "Неопределено"
End Function
Пример основного кода для агрегации данных:
Sub CalculateShiftAggregation()
Dim conn As Object ' ADODB.Connection
Dim rs As Object ' ADODB.Recordset
Dim shiftData As Object
Set shiftData = CreateObject("Scripting.Dictionary")
Dim startDate As Date, endDate As Date
' Инициализация подключения
Set conn = CreateObject("ADODB.Connection")
conn.Open "Driver={Oracle in OraClient};Dbq=YourDatabase;Uid=YourUsername;Pwd=YourPassword;"
' Установка диапазона дат
startDate = CDate("2024-04-01 00:00:00")
endDate = CDate("2024-04-30 23:59:59")
' Запрос данных
Set rs = conn.Execute("SELECT Value, DateTime FROM HourlyValues WHERE DateTime BETWEEN #" & _
Format(startDate, "yyyy-mm-dd hh:nn:ss") & "# AND #" & Format(endDate, "yyyy-mm-dd hh:nn:ss") & "#")
' Инициализация массива для смен
Dim shifts() As String: shifts = Split("А,Б,В,Г", ",")
Dim shiftTotals As Object: Set shiftTotals = CreateObject("Scripting.Dictionary")
For Each shift In shifts
shiftTotals.Add shift, 0
Next
' Обработка результатов
Do While Not rs.EOF
Dim value As Double
Dim shift As String
value = rs.Fields("Value").Value
shift = GetShiftForDatetime(rs.Fields("DateTime").Value)
If shift <> "Неопределено" Then
shiftTotals(shift) = shiftTotals(shift) + value
End If
rs.MoveNext
Loop
' Вывод результатов (пример вывода в Immediate Window)
Dim s As Variant
For Each s In shiftTotals.Keys
Debug.Print "Смена " & s & ": " & shiftTotals(s)
Next
' Закрытие соединения
rs.Close
conn.Close
Set conn = Nothing
Set rs = Nothing
End Sub
1. Функция для взвешенного среднего:
Function CalculateWeightedAverage(parameterID As Integer, startDate As Date, endDate As Date) As Object
Dim conn As Object, rs As Object, weightRS As Object
Set conn = CreateObject("ADODB.Connection")
conn.Open "Driver={Oracle in OraClient};Dbq=YourDatabase;Uid=YourUsername;Pwd=YourPassword;"
' Получаем значения весов
Dim weightQuery As String
weightQuery = "SELECT DateTime, Value AS weight_value FROM HourlyValues " & _
"WHERE CodeId = " & parameterID & " AND DateTime BETWEEN #" & Format(startDate, "yyyy-mm-dd hh:nn:ss") & "# AND #" & Format(endDate, "yyyy-mm-dd hh:nn:ss") & "# AND Value <> 0"
Set weightRS = conn.Execute(weightQuery)
' Словарь для хранения весов
Dim weightData As Object
Set weightData = CreateObject("Scripting.Dictionary")
Do While Not weightRS.EOF
weightData.Add Format(weightRS.Fields("DateTime").Value, "yyyy-mm-dd hh:nn:ss"), weightRS.Fields("weight_value").Value
weightRS.MoveNext
Loop
' Основной запрос на данные
Dim mainQuery As String
mainQuery = "SELECT DateTime, Value FROM HourlyValues " & _
"WHERE CodeId = " & parameterID & " AND DateTime BETWEEN #" & Format(startDate, "yyyy-mm-dd hh:nn:ss") & "# AND #" & Format(endDate, "yyyy-mm-dd hh:nn:ss") & "#"
Set rs = conn.Execute(mainQuery)
' Расчет взвешенного среднего
Dim shiftTotals As Object
Set shiftTotals = CreateObject("Scripting.Dictionary")
Dim shifts() As String: shifts = Split("А,Б,В,Г", ",")
For Each shift In shifts
shiftTotals.Add shift, CreateObject("Scripting.Dictionary")
shiftTotals(shift).Add "sum", 0
shiftTotals(shift).Add "weight_sum", 0
Next
Do While Not rs.EOF
Dim value As Double, dt As String, weight As Double, shift As String
dt = Format(rs.Fields("DateTime").Value, "yyyy-mm-dd hh:nn:ss")
value = rs.Fields("Value").Value
If weightData.Exists(dt) Then
weight = weightData(dt)
shift = GetShiftForDatetime(rs.Fields("DateTime").Value)
If shift <> "Неопределено" Then
shiftTotals(shift)("sum") = shiftTotals(shift)("sum") + (value * weight)
shiftTotals(shift)("weight_sum") = shiftTotals(shift)("weight_sum") + weight
End If
End If
rs.MoveNext
Loop
' Вычисляем средние значения
Dim result As Object
Set result = CreateObject("Scripting.Dictionary")
For Each shift In shifts
If shiftTotals(shift)("weight_sum") > 0 Then
result.Add shift, shiftTotals(shift)("sum") / shiftTotals(shift)("weight_sum")
Else
result.Add shift, 0
End If
Next
Set CalculateWeightedAverage = result
' Закрытие соединения
rs.Close: weightRS.Close: conn.Close
Set conn = Nothing: Set rs = Nothing: Set weightRS = Nothing
End Function
2. Функция для обычной агрегации:
Function CalculateRegularAggregation(parameterID As Integer, startDate As Date, endDate As Date, aggregationType As String) As Object
Dim conn As Object, rs As Object
Set conn = CreateObject("ADODB.Connection")
conn.Open "Driver={Oracle in OraClient};Dbq=YourDatabase;Uid=YourUsername;Pwd=YourPassword;"
Dim query As String
query = "SELECT DateTime, Value FROM HourlyValues " & _
"WHERE CodeId = " & parameterID & " AND DateTime BETWEEN #" & Format(startDate, "yyyy-mm-dd hh:nn:ss") & "# AND #" & Format(endDate, "yyyy-mm-dd hh:nn:ss") & "#"
Set rs = conn.Execute(query)
' Инициализация данных по сменам
Dim shiftTotals As Object
Set shiftTotals = CreateObject("Scripting.Dictionary")
Dim shifts() As String: shifts = Split("А,Б,В,Г", ",")
For Each shift In shifts
shiftTotals.Add shift, CreateObject("Scripting.Dictionary")
shiftTotals(shift).Add "values", CreateObject("System.Collections.ArrayList")
Next
Do While Not rs.EOF
Dim value As Double
Dim shift As String
value = rs.Fields("Value").Value
shift = GetShiftForDatetime(rs.Fields("DateTime").Value)
If shift <> "Неопределено" Then
shiftTotals(shift)("values").Add value
End If
rs.MoveNext
Loop
' Агрегация данных по сменам
Dim result As Object
Set result = CreateObject("Scripting.Dictionary")
For Each shift In shifts
Dim values As Object
Set values = shiftTotals(shift)("values")
If values.Count > 0 Then
Select Case aggregationType
Case "sum"
result.Add shift, Application.WorksheetFunction.Sum(values.ToArray)
Case "min"
result.Add shift, Application.WorksheetFunction.Min(values.ToArray)
Case "max"
result.Add shift, Application.WorksheetFunction.Max(values.ToArray)
Case Else ' avg
result.Add shift, Application.WorksheetFunction.Average(values.ToArray)
End Select
Else
result.Add shift, 0
End If
Next
Set CalculateRegularAggregation = result
' Закрытие соединения
rs.Close: conn.Close
Set conn = Nothing: Set rs = Nothing
End Function
Sub ReplaceFileNameWithFolderName()
Dim folderPath As String
Dim folderName As String
Dim fileName As String
Dim fileExtension As String
Dim newFileName As String
Dim filePath As String
Dim fso As Object
Dim file As Object
Dim folder As Object
' Создаем объект для выбора папки
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Выберите папку"
If .Show <> -1 Then Exit Sub
folderPath = .SelectedItems(1)
End With
' Получаем имя папки
folderName = Mid(folderPath, InStrRev(folderPath, "\") + 1)
' Проверяем наличие файлов в папке
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(folderPath) Then
MsgBox "Папка не найдена.", vbExclamation
Exit Sub
End If
Set folder = fso.GetFolder(folderPath)
' Обрабатываем каждый файл в папке
For Each file In folder.Files
fileName = fso.GetBaseName(file.Name) ' Имя файла без расширения
fileExtension = fso.GetExtensionName(file.Name) ' Расширение файла
' Заменяем последние 19 символов на имя папки
If Len(fileName) > 19 Then
newFileName = Left(fileName, Len(fileName) - 19) & folderName
Else
newFileName = folderName
End If
' Формируем полный путь нового имени файла
filePath = folderPath & "\" & newFileName & IIf(fileExtension <> "", "." & fileExtension, "")
' Переименовываем файл
On Error Resume Next
file.Name = newFileName & IIf(fileExtension <> "", "." & fileExtension, "")
If Err.Number <> 0 Then
MsgBox "Ошибка при переименовании файла: " & file.Name, vbExclamation
Err.Clear
End If
On Error GoTo 0
Next file
MsgBox "Переименование завершено!", vbInformation
End Sub
PDF Splitter
PDF Splitter