Страницы: 1
RSS
Как суммировать время и перевести в ДНИ
 
День добрый, подскажите как назначить переменной (ii) - что это время. При переносе с одного листа на другой, посредством макрос...нужно суммировать время и вывести как  Итог: ДНИ, а не время.
Код
Sub Macro2()
Dim i As Long, LastRow As Long, FreeRowStroy As Long, iCol As Long
Dim ii As Long, CounterStroy As Long, CounterMont As Long, DR As String
Dim FreeRowMont As Long, FreeRow1 As Long, Rng As Range, n As Long, RowStart As Long
    Application.ScreenUpdating = False
    LastRow = Cells(Rows.Count, 2).End(xlUp).Row
    Range(Cells(2, 1), Cells(LastRow + 1, 7)).Clear
    FreeRowStroy = 2
    FreeRowMont = 2
    FreeRow1 = 2
    RowStart = 2
    n = 3
    With Sheets("ПУЛЛ")
        LastRow = .Cells(Rows.Count, 2).End(xlUp).Row
        For i = n To LastRow
            If .Cells(i, 1) <> "" Then
                DR = .Cells(i, 1)
                Cells(FreeRow1, 1) = .Cells(i, 1)
            End If
            For ii = i To LastRow
                If .Cells(ii, 1) = DR Or .Cells(ii, 1) = "" Then
                    If .Cells(ii, 3) > 0 Then
                        Set Rng = Sheets("справочник").Range("B2:C999").Find(what:=.Cells(ii, 2), LookIn:=xlValues, LookAt:=xlWhole)
                        If Not Rng Is Nothing Then
                            If Rng.Column = 2 Then
                                Cells(FreeRowStroy, 2) = .Cells(ii, 2)
                                Cells(FreeRowStroy, 4) = .Cells(ii, 3)  
                                CounterStroy = CounterStroy + 1
                                FreeRowStroy = FreeRowStroy + 1
                            Else
                                Cells(FreeRowMont, 5) = .Cells(ii, 2)
                                Cells(FreeRowMont, 7) = .Cells(ii, 3)
                                CounterMont = CounterMont + 1
                                FreeRowMont = FreeRowMont + 1
                            End If
                        End If
                    End If
                Else
                    i = ii - 1
                    If FreeRowStroy > FreeRowMont Then
                        FreeRow1 = FreeRowStroy
                    Else
                        FreeRow1 = FreeRowMont
                    End If
                    Cells(FreeRow1, 2) = "Итого:" & DR
                    Cells(FreeRow1, 3) = CounterStroy
                    Cells(FreeRow1, 5) = "Итого:" & DR
                    Cells(FreeRow1, 6) = CounterMont
                    Cells(FreeRow1, 4) = Application.Text(ttime, "[hh]:mm")
                    Cells(FreeRow1, 7) = Application.Text(ttime, "[hh]:mm")
                    CounterStroy = 0
                    CounterMont = 0
                    With Range(Cells(RowStart, 1), Cells(FreeRow1, 1))
                        .Merge
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .BorderAround Weight:=xlThin
                    End With
                    Range(Cells(FreeRow1, 2), Cells(FreeRow1, 7)).Interior.ColorIndex = 15
                    Range(Cells(RowStart, 2), Cells(FreeRow1, 7)).Borders.LineStyle = True
                    Cells(FreeRow1, 4) = Application.WorksheetFunction.Sum(Range(Cells(RowStart, 4), Cells(FreeRow1, 4))) / 24
                    Cells(FreeRow1, 7) = Application.WorksheetFunction.Sum(Range(Cells(RowStart, 7), Cells(FreeRow1, 7))) / 24 
                    RowStart = FreeRow1 + 1
                    FreeRow1 = FreeRow1 + 1
                    FreeRowStroy = FreeRow1
                    FreeRowMont = FreeRow1
                    Exit For
                End If
            Next
            If ii > LastRow Then
                Cells(FreeRow1 + 25, 2) = "Итого:" & DR
                Cells(FreeRow1 + 25, 3) = CounterStroy
                Cells(FreeRow1 + 25, 5) = "Итого:" & DR
                Cells(FreeRow1 + 25, 6) = CounterMont
                Cells(FreeRow1 + 25, 4) = Application.Text(ttime, "[hh]:mm")
               Cells(FreeRow1 + 25, 7) = Application.Text(ttime, "[hh]:mm")
                With Range(Cells(RowStart, 1), Cells(FreeRow1 + 25, 1))  
                    .Merge
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .BorderAround Weight:=xlThin
                End With
                Range(Cells(FreeRow1 + 25, 2), Cells(FreeRow1 + 25, 7)).Interior.ColorIndex = 17
                Range(Cells(RowStart, 2), Cells(FreeRow1 + 25, 7)).Borders.LineStyle = True
                Cells(FreeRow1 + 25, 4) = Application.WorksheetFunction.Sum(Range(Cells(RowStart, 4), Cells(FreeRow1 + 5, 4))) / 24  
                Cells(FreeRow1 + 25, 7) = Application.WorksheetFunction.Sum(Range(Cells(RowStart, 7), Cells(FreeRow1 + 5, 7))) / 24 
                Exit Sub
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub
 
vsolovev,
в ексель время и дата считается в сутках
тесть
Код
dim dt as date
dt=1
dt=1 равно сутке, а 0,5=12 часам. ну а далее по аналогии можно перевести все во время
 
ivanok_v2, Ваш пример понятен, а вот в своем коде не могу сообразить

Код
If .Cells(ii, 1) = DR Or .Cells(ii, 1) = "" Then
                    If .Cells(ii, 3) > 0 Then
                        Set Rng = Sheets("справочник").Range("B2:C999").Find(what:=.Cells(ii, 2), LookIn:=xlValues, LookAt:=xlWhole)
                        If Not Rng Is Nothing Then
                            If Rng.Column = 2 Then
                                Cells(FreeRowStroy, 2) = .Cells(ii, 2)
                                Cells(FreeRowStroy, 4) = .Cells(ii, 3) ----эта колонка должна быть ДАТА
                                CounterStroy = CounterStroy + 1
                                FreeRowStroy = FreeRowStroy + 1
                            Else
                                Cells(FreeRowMont, 5) = .Cells(ii, 2)
                                Cells(FreeRowMont, 7) = .Cells(ii, 3) ----эта колонка должна быть ДАТА 
                                CounterMont = CounterMont + 1
                                FreeRowMont = FreeRowMont + 1
                            End If
                        End If
                    End If
                Else

Код
Dim i As Date, LastRow As Date, FreeRowStroy As Date, iCol As Long
'Dim ii As Long, CounterStroy As Long, CounterMont As Long, DR As String
Dim ii As Date, CounterStroy As Long, CounterMont As Long, DR As String

'Dim ii As Date
Dim FreeRowMont As Long, FreeRow1 As Long, Rng As Range, n As Long, RowStart As Long
    Application.ScreenUpdating = False
    LastRow = Cells(Rows.Count, 2).End(xlUp).Row
    Range(Cells(2, 1), Cells(LastRow + 1, 7)).Clear
    FreeRowStroy = 2
    FreeRowMont = 2
    FreeRow1 = 2
    RowStart = 2
    n = 3
  ii = 1
  i = 1
Изменено: vsolovev - 14.09.2018 14:10:42
 
vsolovev, ну ведь Вам подсказали - поменяйте тип переменной ii.
 
Юрий М, Я поменял, все по нулям стало, пост №3 (код вставил)
 
Не вижу я этих нулей. Файл покажите.
 
Юрий М, можно ли так сделать, как в документе на третьем листе нарисовал? подскажите с кодом.
Изменено: vsolovev - 14.09.2018 15:28:50
 
И где там нули?
 
Юрий М, было ранее вот так, сам не заметил
Код
If .Cells(ii, 3) > 0 Then
                        Set Rng = Sheets("справочник").Range("B2:C999").Find(what:=.Cells(ii, 2), LookIn:=xlValues, LookAt:=xlWhole)
                        If Not Rng Is Nothing Then
                            If Rng.Column = 2 Then
                                Cells(FreeRowStroy, 2) = .Cells(ii, 2)
                                Cells(FreeRowStroy, 4) = .Cells(ii, 3).Application.Text(ttime, "[hh]:mm")
                                CounterStroy = CounterStroy + 1
                                FreeRowStroy = FreeRowStroy + 1
                            Else
                                Cells(FreeRowMont, 5) = .Cells(ii, 2)
                                Cells(FreeRowMont, 7) = .Cells(ii, 3).Application.Text(ttime, "[hh]:mm")
                                CounterMont = CounterMont + 1
                                FreeRowMont = FreeRowMont + 1
                            End If
                        End If
                    End If
 
Где в файле нули, о которых Вы говорили?
 
Юрий М, вот так вот было прописал, не заметил свою ошибку....
Cells(FreeRowMont, 7) = .Cells(ii, 3).Application.Text(ttime, "[hh]:mm")
 
Так и нет ответа на дважды заданный вопрос. Ушёл из темы.
 
Цитата
Юрий М написал:
файле нули, о которых Вы говорили
Не уходил я от ответа). Я же говорю, что в коде допустил ошибку....сообщение №9....выдавало везде нули

Сейчас убрал .Application.Text(ttime, "[hh]:mm") , нули пропали
Изменено: vsolovev - 14.09.2018 15:54:49
Страницы: 1
Наверх