Здравствуйте! Пожалуйста, подправьте мой код, ниже пример исходных данных и желаемого результата. Нужно по Номеру короткому(nname) и Уровню(Uroven) сгруппировать строки. Уровень для одного номера может отличаться, но для след. строк Уровень также будет расти внутри группы.
| Код |
|---|
Sub Sostav_po_uzlam()
Application.ScreenUpdating = False ' îòêëþ÷àåì îáíîâëåíèå ýêðàíà
Set wb = ActiveWorkbook
x = 2 'ÁÛËÎ 2 !!!
y = 1
For Each nname In Range("A3:A50000").Cells
x = x + 1
nvbom = WorksheetFunction.CountIf(Range(Cells(x, 1), Cells(100000, 1)), nname) ' ÄÎÁÀÂÈË!!!
For i = 1 To nvbom ' ÄÎÁÀÂÈË!!!
Set IRange = Range(Cells(x, 1), Cells(100000, 1)).Find(What:=nname, LookIn:=xlValues)
If IRange Is Nothing Then GoTo Sled
iRow = IRange.Row
iColumn = IRange.Column
Uroven = Cells(iRow, 4)
If iRow = x + 1 Then GoTo Sled ' äîáàâèë åñëè èñêîìàÿ ñòðîêà ñëåä îò èñõîäíîé
Range(Cells(iRow, 1), Cells(iRow, 20)).Cut
Cells(x + 1, y).Insert
Index = iRow
If iRow = x + 1 Then GoTo Sled ' äîáàâèë åñëè èñêîìàÿ ñòðîêà ñëåä îò èñõîäíîé
While Cells(Index, 4).Value > Uroven 'Or Cells(iRow + 1, 4).Value = Uroven
Index = Index + 1
x = x + 1 ' ÄÎÁÀÂÈË !!!
Range(Cells(Index, 1), Cells(Index, 20)).Cut
Cells(x + 1, y).Insert ' ÁÛËÎ + 0 !!!
Wend
Next
Sled:
Next
End Sub
|
Изменено: - 24.01.2024 14:25:01
