Уважаемые знатоки VBA есть таблица учета выездов Мобильных ДГА и раз в месяц необходимо собрать данные в один лист Я попробовал написать Макрос но он у меня собирает их не учитывая повторяющих данных (объектов) А мне нужно чтобы данные первых 8 столбцов не повторялись а значений остальных столбцов были на против. Модуль макроса 4-тый Я скрыл столбцы не относящийся к этому макросу Я новичок в VBA может что то не догоняю еще вот и мучаюсь ломая голову :-) Пример Кода [vba]
Код
Sub ts() Dim c As Range, LastRow1 As Integer, LastRow2 As Integer, s As Integer, rz As Integer
Application.Calculation = xlCalculationManual Application.ScreenUpdating = False For i = 2 To Sheets.Count
With Sheets(i) Dim A As Integer, B As Integer LastRow2 = Sheets(1).Cells(Rows.Count, 11).End(xlUp).Row LastRow1 = .Cells(3, 1).End(xlDown).Row
s = i If s = 2 Then s = 0 ElseIf i = 3 Then s = 8 Else s = (i - 2) * 7 + 1 End If Sheets(i).Range("A3:H" & LastRow1 - 1).Copy Sheets(1).Cells(LastRow2 + 1, 11) For Each c In .Range(.[I3], .Cells(LastRow1, "V")) A = Hour(.Cells(c.Row, c.Column)) B = Hour(.Cells(c.Row, c.Column + 1)) If c.Value = "" Then R = "" End If If B - A > 12 Then R = 2 ElseIf Not c.Value = "" Then R = 1 End If
Select Case c.Column Case 9: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 18) = R: 'Sheets(1).Cells(LastRow + 2, s+18) = Sheets(1).Cells(1, c.Column).Value Case 11: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 19) = R: 'Sheets(1).Cells(LastRow2 - 2, s+19) = Sheets(1).Cells(1, c.Column).Value Case 13: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 20) = R: 'Sheets(1).Cells(LastRow2 - 2, s+20) = Sheets(1).Cells(1, c.Column).Value Case 15: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 21) = R: 'Sheets(1).Cells(LastRow2 - 2, s+21) = Sheets(1).Cells(1, c.Column).Value Case 17: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 22) = R: 'Sheets(1).Cells(LastRow2 - 2, s+22) = Sheets(1).Cells(1, c.Column).Value Case 19: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 23) = R: 'Sheets(1).Cells(LastRow2 - 2, s+23) = Sheets(1).Cells(1, c.Column).Value Case 21: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 24) = R: 'Sheets(1).Cells(LastRow2 - 2, s+24) = Sheets(1).Cells(1, c.Column).Value
End Select
Next c
End With Next i End Sub
[/vba] [moder]Нарушение п.3 Правил форума в части тегов. Исправил.[/moder]
Уважаемые знатоки VBA есть таблица учета выездов Мобильных ДГА и раз в месяц необходимо собрать данные в один лист Я попробовал написать Макрос но он у меня собирает их не учитывая повторяющих данных (объектов) А мне нужно чтобы данные первых 8 столбцов не повторялись а значений остальных столбцов были на против. Модуль макроса 4-тый Я скрыл столбцы не относящийся к этому макросу Я новичок в VBA может что то не догоняю еще вот и мучаюсь ломая голову :-) Пример Кода [vba]
Код
Sub ts() Dim c As Range, LastRow1 As Integer, LastRow2 As Integer, s As Integer, rz As Integer
Application.Calculation = xlCalculationManual Application.ScreenUpdating = False For i = 2 To Sheets.Count
With Sheets(i) Dim A As Integer, B As Integer LastRow2 = Sheets(1).Cells(Rows.Count, 11).End(xlUp).Row LastRow1 = .Cells(3, 1).End(xlDown).Row
s = i If s = 2 Then s = 0 ElseIf i = 3 Then s = 8 Else s = (i - 2) * 7 + 1 End If Sheets(i).Range("A3:H" & LastRow1 - 1).Copy Sheets(1).Cells(LastRow2 + 1, 11) For Each c In .Range(.[I3], .Cells(LastRow1, "V")) A = Hour(.Cells(c.Row, c.Column)) B = Hour(.Cells(c.Row, c.Column + 1)) If c.Value = "" Then R = "" End If If B - A > 12 Then R = 2 ElseIf Not c.Value = "" Then R = 1 End If
Select Case c.Column Case 9: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 18) = R: 'Sheets(1).Cells(LastRow + 2, s+18) = Sheets(1).Cells(1, c.Column).Value Case 11: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 19) = R: 'Sheets(1).Cells(LastRow2 - 2, s+19) = Sheets(1).Cells(1, c.Column).Value Case 13: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 20) = R: 'Sheets(1).Cells(LastRow2 - 2, s+20) = Sheets(1).Cells(1, c.Column).Value Case 15: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 21) = R: 'Sheets(1).Cells(LastRow2 - 2, s+21) = Sheets(1).Cells(1, c.Column).Value Case 17: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 22) = R: 'Sheets(1).Cells(LastRow2 - 2, s+22) = Sheets(1).Cells(1, c.Column).Value Case 19: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 23) = R: 'Sheets(1).Cells(LastRow2 - 2, s+23) = Sheets(1).Cells(1, c.Column).Value Case 21: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 24) = R: 'Sheets(1).Cells(LastRow2 - 2, s+24) = Sheets(1).Cells(1, c.Column).Value
End Select
Next c
End With Next i End Sub
[/vba] [moder]Нарушение п.3 Правил форума в части тегов. Исправил.[/moder]n-ergash