Страницы: 1
RSS
Сведение по признаку, Исправить код VBA Excel
 
Здравствуйте! Пожалуйста, подправьте мой код, ниже пример исходных данных и желаемого результата. Нужно по Номеру короткому(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
Изменено: romeiro - 24.01.2024 14:25:01
Страницы: 1
Наверх