Sub ddd()
Dim i As Integer
Dim Rcell As Range
Dim myRange As Range
Dim DRange As Range
Dim MRange As Range
Dim NRange As Range
Dim RRange As Range
Application.ScreenUpdating = False
Range("A1:E10000").Clear
ilastrow = Worksheets("Лист2").Cells(Rows.Count, 1).End(xlUp).Row
Set myRange = Worksheets("Лист2").Range("A2:A" & ilastrow)
For Each Rcell In myRange
If Rcell.Value = "Д" And Rcell.Offset(0, 2).Value > 0 Then
If DRange Is Nothing Then
Set DRange = Rcell.Offset(0, 1).Resize(, 4)
Else
Set DRange = Union(Rcell.Offset(0, 1).Resize(, 4), DRange)
End If
End If
If Rcell.Value = "М" And Rcell.Offset(0, 2).Value > 0 Then
If MRange Is Nothing Then
Set MRange = Rcell.Offset(0, 1).Resize(, 4)
Else
Set MRange = Union(Rcell.Offset(0, 1).Resize(, 4), MRange)
End If
End If
If Rcell.Value = "Н" And Rcell.Offset(0, 2).Value > 0 Then
If NRange Is Nothing Then
Set NRange = Rcell.Offset(0, 1).Resize(, 4)
Else
Set NRange = Union(Rcell.Offset(0, 1).Resize(, 4), NRange)
End If
End If
If Rcell.Value = "Р" And Rcell.Offset(0, 2).Value > 0 Then
If RRange Is Nothing Then
Set RRange = Rcell.Offset(0, 1).Resize(, 4)
Else
Set RRange = Union(Rcell.Offset(0, 1).Resize(, 4), RRange)
End If
End If
Next Rcell
ilastrow2 = Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row
Worksheets("Лист1").Cells(ilastrow2 + 1, 2) = "Дымоход"
Worksheets("Лист2").Range("C1:E1").Copy
ActiveSheet.Paste Destination:=Worksheets("Лист1").Cells(ilastrow2 + 1, 3)
If Not DRange Is Nothing Then DRange.Copy
Cells(Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row + 1, 2).Select
ActiveSheet.Paste
ilastrow2 = Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row
Worksheets("Лист1").Cells(ilastrow2 + 1, 2) = "Материал"
Worksheets("Лист2").Range("C1:E1").Copy
ActiveSheet.Paste Destination:=Worksheets("Лист1").Cells(ilastrow2 + 1, 3)
If Not MRange Is Nothing Then MRange.Copy
Cells(Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row + 1, 2).Select
ActiveSheet.Paste
ilastrow2 = Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row
Worksheets("Лист1").Cells(ilastrow2 + 1, 2) = "НРасходы"
Worksheets("Лист2").Range("C1:E1").Copy
ActiveSheet.Paste Destination:=Worksheets("Лист1").Cells(ilastrow2 + 1, 3)
If Not NRange Is Nothing Then NRange.Copy
Cells(Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row + 1, 2).Select
ActiveSheet.Paste
ilastrow2 = Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row
Worksheets("Лист1").Cells(ilastrow2 + 1, 2) = "Работы"
Worksheets("Лист2").Range("C1:E1").Copy
ActiveSheet.Paste Destination:=Worksheets("Лист1").Cells(ilastrow2 + 1, 3)
If Not RRange Is Nothing Then RRange.Copy
Cells(Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row + 1, 2).Select
ActiveSheet.Paste
Application.ScreenUpdating = True
End Sub |