Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1 2 След.
RSS
Нумерация непустых строк. VBA
 
#1
08.02.2019 15:48:43
Добрый день. Помогите создать нумерацию не пустых строк средствами VBA, без формул в ячейках. Нумерация должна начинаться с 7 строки в колонке B. При очистке строки нумерация в строке должна удаляться и продолжить нумерацию со следующей не пустой строки.
Имеющийся код начинает нумеровать с первой строки и не очищает значения с последующим продолжением нумерации.
Код
Application.EnableEvents = False
   RowMax = Cells.SpecialCells(xlCellTypeLastCell).Row
   ColMax = Cells.SpecialCells(xlCellTypeLastCell).Column
   n = 0
   For i = 1 To RowMax
      For j = 1 To ColMax
         If Not IsEmpty(Cells(i, j)) Then
            n = n + 1
            Cells(i, 2) = n
            Exit For
         End If
      Next j
   Next i
Application.EnableEvents = True
 
 
 
#2
08.02.2019 16:03:35
Код
Sub RenumB()
  Dim b As Range, c As Range, i&, r&
  For r = 1 To Cells.SpecialCells(xlCellTypeLastCell).Row
    If WorksheetFunction.CountBlank(Rows(r)) < Columns.Count Then If b Is Nothing Then Set b = Cells(r, 2) Else Set b = Union(b, Cells(r, 2))
  Next
  i = 1
  For Each c In b
    c = i: i = i + 1
  Next
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#3
08.02.2019 16:06:39
Цитата
Hashtag написал: не очищает значения с последующим продолжением нумерации
Событие листа...
 
 
 
#4
08.02.2019 19:33:11
Ігор Гончаренко
vikttur
Не удаляется нумерация в очищенной от записей строке. Также, при попытке очистить всю нумерацию выдает "Run-time error 424  Object required"? а в коде выделяется строка For Each c In b

Посмотрите, пожалуйста, что в коде не так?

Скрытый текст
Изменено: Hashtag - 08.02.2019 19:36:13
 
 
 
#5
08.02.2019 19:44:16
Код
Sub num()
lr = Cells(Rows.Count, 3).End(xlUp).Row
Range(Cells(1, 1), Cells(lr, 1)).Clear
For i = 7 To lr
    If Application.WorksheetFunction.CountA(Rows(i)) <> 0 Then
        k = k + 1
        Cells(i, 1) = k
    End If
Next i
End Sub
 
 
 
#6
08.02.2019 21:13:04
Vintic
Почти работает! Но если очищать строку с конца списка, например, последнюю строку, то номер строки не удаляется.
 
 
 
#7
08.02.2019 21:24:47
Файл не смотрел... Попробуйте увеличить переменную номера последней строки на единичку:
lr = Cells(Rows.Count, 3).End(xlUp).Row +1
 
 
 
#8
08.02.2019 21:25:38
Подлечил немного) Надеюсь сейчас все нормально
Код
Sub num()
lr = Cells(Rows.Count, 3).End(xlUp).Row
Range(Cells(1, 1), Cells(lr + 1, 1)).Clear
For i = 7 To lr
    If Application.WorksheetFunction.CountA(Rows(i)) <> 0 Then
        k = k + 1
        Cells(i, 1) = k
    End If
Next i
End Sub
 
 
 
#9
08.02.2019 21:27:45
Цитата
Юрий М написал:
Попробуйте увеличить переменную номера последней строки на единичку
Спасибо, сделал почти так же
 
 
 
#10
08.02.2019 21:28:43
Юрий М
Цитата
lr = Cells(Rows.Count, 3).End(xlUp).Row +1
Если снизу очищать несколько строк, номера остаются кроме одного
 
 
 
#11
08.02.2019 21:33:26
см.вложение
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#12
08.02.2019 21:35:24
Vintic
Тоже самое. Если очищать несколько строк снизу, все номера напротив, кроме одного, остаются.
 
 
 
#13
08.02.2019 21:47:59
Ігор Гончаренко
В вашем примере ни один номер, к сожалению, автоматически не удаляется, вариант Vintic сейчас ближе всего к правде.
 
 
 
#14
08.02.2019 21:56:22
Цитата
Hashtag написал:
Если снизу очищать несколько строк
В каких ячейках (столбцах) Вы удаляете значения?
 
 
 
#15
08.02.2019 22:03:06
Юрий М
В этом примере очистите диапазон C18:F21 и C7:F10. Сверху номера автоматом удаляются, снизу - нет. Код от Vintic.
Изменено: Hashtag - 08.02.2019 22:04:01
 
 
 
#16
08.02.2019 22:07:40
Так лучше?
Мой канал
 
 
 
#17
08.02.2019 22:37:52
Код
lr = Cells(Rows.Count, 1).End(xlUp).Row
 
 
 
#18
08.02.2019 23:11:23
skais675
Если снизу или сверху очищать строки, номера удаляются хорошо.
1.Но теперь если очищать снизу колонку C, номера удаляются, а должны удаляться только при полностью очищенной строке в диапазоне C:F.
2.При копировании кнопкой не происходит нумерация, если не заполнена ячейка C3, но должна происходить, даже если заполнена любая ячейка в диапазоне C:F.
 
 
 
#19
09.02.2019 01:38:10
Пожалуйста, проверьте:
Код
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim maks As Long, stk As Long, strk
    ReDim strk(1 To 5)
    For stk = 3 To 6
        strk(stk - 1) = Cells(Rows.Count, stk).End(xlUp).Row
    Next
    strk(1) = Cells(Rows.Count, 1).End(xlUp).Row
    maks = Application.Max(strk)
    If Intersect(Target, Range("c7:f" & maks)) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    If maks <= 7 And Application.CountA(Range("c7:f7")) = 0 Then
        Range("a7").ClearContents: GoTo konets
    Else
        Range("a7:a" & maks).ClearContents
    End If
    strk = Empty
    stk = 0
    For Each strk In Range("c7:f" & maks).Rows
        If Application.CountA(strk) > 0 Then
            stk = stk + 1
            Range("a" & strk.Row).Value = stk
        End If
    Next
konets: Application.EnableEvents = True
End Sub
 
 
 
#20
09.02.2019 07:55:48
Ну раз такое дело, тогда так.
Мой канал
 
 
 
#21
09.02.2019 13:32:11
skais675
Все безупречно, спасибо вам огромное.
ocet p
Не удалось проверить ваш код, постоянно была ошибка в этом месте:
Код
If Intersect(Target, Range("c7:f" & maks)) Is Nothing Then


От себя хочу поблагодарить всех, кто отозвался решить эту задачу и внес свой вклад в ее разрешение, не оставили наедине с проблемой и довели дело до конца. Спасибо всем!
 
 
 
#22
09.02.2019 13:39:15
Цитата
Hashtag написал: ocet p Не удалось проверить ваш код
Код в модуле листа? Нужно показать, тогда и на ошибку укажут.
 
 
 
#23
09.02.2019 14:16:43
vikttur
Цитата
Код в модуле листа? Нужно показать, тогда и на ошибку укажут.
Если в модуле листа, ошибку не выдает, но и нумерация не происходит.
 
 
 
#24
09.02.2019 14:22:01
Код
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = 0
Call num

Название процедуры указывает на то, что это - процедура отслеживания события листа (Worksheet_Change) - код должен быть в модуле листа.
Последняя показанная строка - переход к выпонению макроса  num. Да, он у Вас есть... но пустой.

По коду Worksheet_Change. Вы изменили предложенный макрос.
Код
 If Intersect(Target, Range("C3:F3")) Is Nothing Then Exit Sub

Если изменения произошли не в диапазоне C3:F3, уходим. Т.е. до проверки диапазона Range("c7:f" & maks) никак не дойдет

Это вообще лишнее:
Код
  Application.EnableEvents = Truе 
  Application.EnableEvents = False
 
 
 
#25
09.02.2019 14:39:52
Hashtag, в #17 я предложил минимальную правку (к старым файлам), которая решала проблему.
 
 
 
#26
09.02.2019 17:06:07
vikttur
Вы правы, вариант от ocet p работает.
 
 
 
#27
24.07.2026 13:16:06
Добрый день. Новую тему создавать не стал, т.к. макрос взял из этой темы.

Ребят, помогите пожалуйста заточить этот макрос под умную таблицу:
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim maks As Long, stk As Long, strk
    ReDim strk(1 To 5)
    For stk = 3 To 6
        strk(stk - 1) = Cells(Rows.Count, stk).End(xlUp).Row
    Next
    strk(1) = Cells(Rows.Count, 1).End(xlUp).Row
    maks = Application.Max(strk)
    If Intersect(Target, Range("a2:e" & maks)) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    If maks <= 2 And Application.CountA(Range("a2:e2")) = 0 Then
        Range("b2").ClearContents: GoTo konets
    Else
        Range("b2:b" & maks).ClearContents
    End If
    strk = Empty
    stk = 0
    For Each strk In Range("a2:e" & maks).Rows
        If Application.CountA(strk) > 0 Then
            stk = stk + 1
            Range("b" & strk.Row).Value = stk
        End If
    Next
konets: Application.EnableEvents = True
End Sub
Макрос работает, но он в строку итогов тоже цифру пишет, а в строке итогов нумерация не нужна.
Ну и хотелось бы понять можно ли этот макрос заточить под умную таблицу.

Пытаюсь сделать вот так:
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim maks As Long, stk As Long, strk
    ReDim strk(1 To 5)
    For stk = 3 To 6
        strk(stk - 1) = Cells(Rows.Count, stk).End(xlUp).Row
    Next
    strk(1) = Cells(Rows.Count, 1).End(xlUp).Row
    maks = Application.Max(strk)
    If Intersect(Target, Range("tblShablon[[Код]:[Наименование]]" & maks)) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    If maks <= 2 And Application.CountA(Range("tblShablon[[Код]:[Наименование]]")) = 0 Then
        Range("tblShablon[№ пп]").ClearContents: GoTo konets
    Else
        Range("tblShablon[№ пп]" & maks).ClearContents
    End If
    strk = Empty
    stk = 0
    For Each strk In Range("tblShablon[[Код]:[Наименование]]" & maks).Rows
        If Application.CountA(strk) > 0 Then
            stk = stk + 1
            Range("tblShablon[№ пп]" & strk.Row).Value = stk
        End If
    Next
konets: Application.EnableEvents = True
End Sub
но ругается на строку:
Код
If Intersect(Target, Range("tblShablon[[Код]:[Наименование]]" & maks)) Is Nothing Then
 
 
 
#28
24.07.2026 13:41:01
Именно макрос нужен? Задача решается и формулой.
Код
=ЕСЛИ(СЧЁТЗ(tblShablon[@[Торговая марка]:[Сумма]];[@Код])>0;МАКС(B$1:B1)+1;"")
 
 
 
#29
24.07.2026 14:03:12
Код
Option Explicit

Const PP_COLUMN_NAME = "№ пп"

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim tb As ListObject
    Set tb = ActiveSheet.ListObjects(1)
    If Intersect(Target, tb.DataBodyRange) Is Nothing Then Exit Sub
'    If Not Intersect(Target, tb.ListColumns(PP_COLUMN_NAME).DataBodyRange) Is Nothing Then
'        If Target.Cells.Count = 1 Then Exit Sub
'    End If
    
    Dim aNumbers As Variant
    aNumbers = GetNumberArray(tb)
    
    Application.EnableEvents = False
    tb.ListColumns(PP_COLUMN_NAME).DataBodyRange.Value = aNumbers
    Application.EnableEvents = True
End Sub
Private Function GetNumberArray(tb) As Variant
    Dim xExept As Long
    xExept = tb.ListColumns(PP_COLUMN_NAME).Range.Column - tb.Range.Column + 1
    
    Dim aBody As Variant, aNumb As Variant, yb As Long, numb As Long
    aBody = tb.DataBodyRange
    ReDim aNumb(1 To UBound(aBody, 1), 1 To 1)
    For yb = 1 To UBound(aBody, 1)
        If IsRowNonEmpty(aBody, yb, xExept) Then
            numb = numb + 1
            aNumb(yb, 1) = numb
        End If
    Next
    GetNumberArray = aNumb
End Function
Private Function IsRowNonEmpty(aBody As Variant, yb As Long, xExept As Long) As Boolean
    Dim xb As Long
    For xb = 1 To UBound(aBody, 2)
        If xb <> xExept Then
            If Not IsError(aBody(yb, xb)) Then
                If Not IsEmpty(aBody(yb, xb)) Then
                    IsRowNonEmpty = True
                    Exit Function
                End If
            End If
        End If
    Next
End Function
 
 
 
#30
24.07.2026 14:28:04
МатросНаЗебре, спасибо вам большое, но вы новый макрос написали, :) а я очень хотел понять где я ошибку допустил в макросе из этой темы.
Или этот макрос с умной таблицей подружить нельзя?
 
 
 
Страницы: 1 2 След.
Читают тему
Наверх