Массив запарил :(

[XPress]

Имеется промежуток времени [time1, time2], двумерный массив tarif(4,2), который определяет тарификацию времени! А именно: элементы с индексом (х, 1) это начало действия тарифа(х:хх), элементы с индексом (х, 2) - стоимость одного часа, например:

tarif(1, 1) = 8:00; tarif(1, 2) = 2.00
tarif(2, 1) = 12:00; tarif(2, 2) = 3.00
tarif(3, 1) = 16:00; tarif(3, 2) = 4.50
tarif(4, 1) = 20:00; tarif(4, 2) = 4.00

Нужно написать такую функцию:

Код: Выделить всё

private function raschet(time1 as string, time2 as string) as single

end sub

которая высчитывает согласно указанным тарифам, на пример если человек просидел за компом с 10:45 до 12:16 считается сначала, с 10:45 до 12:00 по tarif(1, 2), так как 8:00<10:45<12:00 , а дальше по tarif(2, 2), так как 12:00<12:16<16:00. В итоге raschet("10:45", "12:16")=3.30.
Нужен оптимальный алгоритм решения этой задачи, всем заранее спасибо!

[Zoomie]

Можно ли упростить задачу так:

Dim Mas (0 To 23) as String

0 To 23 - это часы, а значения в них -тариф.

Можно так упростить?

[Zoomie]

Вот наваял какую-то функцию:

Код: Выделить всё


Dim Tarif(0 To 23) As String

Private Sub Form_Load()
Dim i As Integer
For i = 0 To 23
Tarif(i) = Format(Rnd * 30, "0.00")
Next i
MsgBox Money("3:25", "5:25")
End Sub

Private Function Money(Time1 As String, Time2 As String) As Single
Dim i As Integer
Dim Sum As Single
Sum = 0
If Hour(Time1) <> Hour(Time2) Then
For i = Hour(Time1) To Hour(Time2)
If i = Hour(Time1) Then
Sum = Sum + (60 - Minute(Time1)) * Tarif(i) / 60
GoTo 1
ElseIf i = Hour(Time2) Then
Sum = Sum + Minute(Time2) * Tarif(i) / 60
GoTo 1
Else
Sum = Sum + Tarif(i)
End If
1: Next i
Money = Sum
Else
Money = (Minute(Time2) - Minute(Time1)) * Tarif(Hour(Time1)) / 60
End If
End Function



Если что не так - спрашивай

[XPress]

Zoomie
Пасиб, что отозвался помочь!
Алгоритм твой ништячный слов нет, но если тариф начинается не с ровных часов, то есть скажем в 8:30, то что делать тогда?

[Zoomie]

Можно попробовать конечно и двумерным масивом.

Думаю, код выложу через часа 3 , может раньше

В этом коде есть еще один минус:

Если с 9:00 до 6:00 ,т.е. переход на следующий день - это тоже надо учитывать в функции.

В общем я подумаю, допишу и выложу!

[XPress]

Zoomie
Ага было бы здорово!
Буду ждать!

[GSerg]

Такой вопрос у меня...

Если человек сидел сутки, с 10:00 до 10:01, то функция вернёт какую сумму?..

[XPress]

GSerg В этом случае можно какую нить другую уловку придумать, как я сказал те в форуме VBnet.ru
Ну хай если есть какие нить домыслы то вали их сюда

[GSerg]

Не знаю, чё получилось, особо не тестил, но вроде работает...
Переход через полночь, а также целые сутки учитываются.

Код: Выделить всё

Option Explicit

Private Type Tariff
  From As Date
  Amount As Currency
End Type

Private Sub Form_Load()
  Dim arr(1 To 4) As Tariff
 
  'Подразумевается, что массив тарифов отсортирован по возрастанию времени.
  With arr(1)
    .From = TimeSerial(8, 0, 0)
    .Amount = 2
  End With
 
  With arr(2)
    .From = TimeSerial(12, 0, 0)
    .Amount = 3
  End With
 
  With arr(3)
    .From = TimeSerial(16, 0, 0)
    .Amount = 4.5
  End With
 
  With arr(4)
    .From = TimeSerial(20, 0, 0)
    .Amount = 4
  End With
 
  MsgBox GetAmount(arr, "29.10.2005 10:45:00", "30.10.2005 10:44:00")
End Sub



Private Function NextElem(arr() As Tariff, ByVal index As Long) As Long
  NextElem = index + 1
  If NextElem > UBound(arr) Then NextElem = LBound(arr)
End Function

Private Function PrevElem(arr() As Tariff, ByVal index As Long) As Long
  PrevElem = index - 1
  If PrevElem < LBound(arr) Then PrevElem = UBound(arr)
End Function

Private Function MAX(ByVal v1 As Date, ByVal v2 As Date) As Date
  If v1 > v2 Then MAX = v1 Else MAX = v2
End Function

Private Function MIN(ByVal v1 As Date, ByVal v2 As Date) As Date
  If v1 > v2 Then MIN = v2 Else MIN = v1
End Function

Private Function Get24Worth(Tariffs() As Tariff) As Currency
  Dim i As Long, t As Date
 
  For i = LBound(Tariffs) To UBound(Tariffs)
    t = Abs((Tariffs(NextElem(Tariffs, i)).From - Tariffs(i).From))
    Get24Worth = Get24Worth + Tariffs(i).Amount * (Hour(t) + Minute(t) / 60 + Second(t) / 3600)
  Next
End Function

Private Function GetAmount(Tariffs() As Tariff, ByVal DateFrom As Date, ByVal DateTo As Date) As Currency
  Dim i As Long, diff As Long, e1 As Long, e2 As Long
  Dim t As Date, Worth24 As Currency
 
  If DateTo < DateFrom Then Err.Raise 5
 
  diff = Fix(DateTo - DateFrom)
 
  If diff >= 1 Then
    Worth24 = Get24Worth(Tariffs)
    GetAmount = Worth24 * diff
    DateTo = DateTo - diff
  End If
 
  If DateTo = DateFrom Then Exit Function
 
  DateFrom = DateFrom - Fix(DateFrom)
  DateTo = DateTo - Fix(DateTo)
 
  e1 = UBound(Tariffs) + 1
  e2 = e1
  For i = LBound(Tariffs) To UBound(Tariffs)
    If Tariffs(i).From >= DateFrom Then
      If e1 > PrevElem(Tariffs, i) Then e1 = PrevElem(Tariffs, i)
    End If
   
    If Tariffs(i).From >= DateTo Then
      If e2 > PrevElem(Tariffs, i) Then e2 = PrevElem(Tariffs, i)
    End If
  Next
 
  If e1 = e2 Then
    If DateTo > DateFrom Then
      t = DateTo - DateFrom
      GetAmount = GetAmount + Tariffs(e1).Amount * (Hour(t) + Minute(t) / 60 + Second(i) / 3600)
    Else
      If Worth24 = 0 Then Worth24 = Get24Worth(Tariffs)
      t = Abs(Tariffs(NextElem(Tariffs, e2)).From - DateTo)
      GetAmount = GetAmount + Worth24 - GetAmount(Tariffs, DateTo, DateFrom)
    End If
  ElseIf e2 > e1 Then
    For i = e1 To e2
      t = MAX(DateFrom, Tariffs(i).From) - MIN(DateTo, Tariffs(NextElem(Tariffs, i)).From)
      GetAmount = GetAmount + Tariffs(i).Amount * (Hour(t) + Minute(t) / 60 + Second(i) / 3600)
    Next
  Else
    For i = e1 To UBound(Tariffs)
      t = Abs(MAX(DateFrom, Tariffs(i).From) - Tariffs(NextElem(Tariffs, i)).From)
      GetAmount = GetAmount + Tariffs(i).Amount * (Hour(t) + Minute(t) / 60 + Second(i) / 3600)
    Next
    For i = LBound(Tariffs) To e2
      t = Abs(Tariffs(i).From - MIN(DateTo, Tariffs(NextElem(Tariffs, i)).From))
      GetAmount = GetAmount + Tariffs(i).Amount * (Hour(t) + Minute(t) / 60 + Second(i) / 3600)
    Next
  End If
End Function

[Zoomie]

Мда громоздко!
Но и у меня изменения есть!

У меня по тому-же принцыпу, только я его изменил:

Код: Выделить всё

Dim Tarif(0 To 143) As Variant

Public Function SetTarif()
Dim i As Byte
For i = 0 To 143
Tarif(i) = "X"
Next i
Tarif(8 * 6 + 3) = 3.25
Tarif(9 * 6) = 4.45
End Function

Public Function GetFullDay() As Single
Dim i As Byte
Dim Sum As Single
Dim IndTar As Single
i = 143
Do While Tarif(i) = "X"
i = i - 1
If Tarif(i) <> "X" Then
IndTar = Tarif(i)
Exit Do
End If
Loop
For i = 0 To 143
If Tarif(i) <> "X" Then
IndTar = Tarif(i)
End If
Sum = Sum + IndTar
Next i
GetFullDay = Sum
End Function

Private Function Money(Time1 As String, Time2 As String, Days As Integer) As Single
Dim i As Integer
Dim nTime1 As Byte
Dim nTime2 As Byte
Dim IndTar As Single
Dim Sum As Single
Dim FullDay As Single

Sum = 0
nTime1 = Hour(Time1) * 6 + Minute(Time1) \ 10
nTime2 = Hour(Time2) * 6 + Minute(Time2) \ 10

i = 143
Do While Tarif(i) = "X"
i = i - 1
If Tarif(i) <> "X" Then
IndTar = Tarif(i)
Exit Do
End If
Loop

For i = 0 To 143
If Tarif(i) <> "X" Then
IndTar = Tarif(i)
End If
If i = nTime1 Then
Exit For
End If
Next i

If nTime1 * 10 + Minute(Time1) Mod 10 < nTime2 * 10 + Minute(Time2) Then
For i = nTime1 To nTime2 - 1
If Tarif(i) <> "X" Then
IndTar = Tarif(i)
End If
If i = nTime1 Then
Sum = Sum + IndTar / 10 * (10 - Minute(Time1) Mod 10)
ElseIf i = nTime2 Then
Sum = Sum + IndTar / 10 * Minute(Time2) Mod 10
Else
Sum = Sum + IndTar
End If
Next i
Money = Sum + Days * GetFullDay
ElseIf nTime1 * 10 + Minute(Time1) Mod 10 = nTime2 * 10 + Minute(Time2) Then
Money = IndTar + Days * GetFullDay
ElseIf nTime1 * 10 + Minute(Time1) Mod 10 > nTime2 * 10 + Minute(Time2) Then
For i = nTime2 - 1 To nTime1
If Tarif(i) <> "X" Then
IndTar = Tarif(i)
End If
If i = nTime1 Then
Sum = Sum + IndTar / 10 * (10 - Minute(Time1) Mod 10)
ElseIf i = nTime2 Then
Sum = Sum + IndTar / 10 * Minute(Time2) Mod 10
Else
Sum = Sum + IndTar
End If
Next i
Money = GetFullDay - Sum + Days * GetFullDay
End If
End Function

Private Sub Command1_Click()
[b]SetTarif[/b]
MsgBox Money("8:01", "9:00", 0)
End Sub



Если надо спрашивайте!

[XPress]

GSerg Грамотно, ништяк, доходчево! А как ты предложешь отсортировать выше указанный мной масив тарифов. Пасиб большое!
Zoomie А в твоем коде я как-то не догнал как тарифы назначать? Может объяснишь? Спасибо!

[GSerg]

А как ты предложешь отсортировать выше указанный мной масив тарифов.

А когда ты его заполняешь, заполняй по возрастанию. Как у меня показано.

[Zoomie]

См. функцию SetTarif

Принцип тарифов такой:
1) Весь тариф заполняется значениями "X"
Это для того чтобы были вычисления надежней и избежать ошибок

2) Потом назначаем в массив Tarif (который 0 то 143) время по формуле

Tarif(X) = Сумма (Single \ Double)
X = Hour(Time) * 6 + Minute(Time) \ 10

[GAGArin]

Код: Выделить всё

Public  timeStart as double' Время старта рассчета
Public timeEnd as double' Время конца рассчета
Dim dblCost(n+1) as Double' Массив цен по периодам (n периодов по возрастанию времени)
Dim dblStart(n+1) as Double' Массив стартов периодов (в долях часа, тоже по возрастанию времени)
dblStart (n+1) = 24' Это чтоб с концом не париться

Function Max (time1,time2 as Double) as double
  if time1>time2 then Max=time1
  else Max=time2
End function
Function Min (time1, time2 as double) as double
  'Аналогично Max
end function

Function FullDay
  for a=0 to n
    FullDay= fullDay+Interval(max(dblStart(a),StartTime),min(dblstart(a+1),EndTime))*value(a)
  next a
End function

Function interval (timeStart, timeEnd as double) as double
  if timeEnd<timeStart then Interval=0
  else interval=timeend-timestart
End function


Усё, вроде должно работать, писал прям в окошке, не проверял. Но идея такая. Ну массив можно взять двумерный (вместо двух), или свой тип организовать, тут не суть важно.