Sub Macro2()
Dim i As Long, LastRow As Long, FreeRowStroy As Double, iCol As Long
Dim ii As Date, 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)
''''''' Dim ds As Double
''''''' ds = CDbl(CDate(Cells(3, 3).Value))
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
|
