Всем добрый вечер! Появилась потребность постоянно нумеровать строки, при этом таблица динамичная, каждый день строки удаляются и добавляются. Протаскивать не получается, потому что встречаются строки которые нумеровать ненужно, так как они являются заголовками разделов. Нашёл макрос, но он нумерует все строки подряд. Есть идея сделать эти заголовки жёлтыми и прописать в макросе, чтобы нумеровались только белые строки. Подскажите как это сделать. Макрос прилагаю. [vba]
Код
Sub RowsNum() 'нумерация ячеек в первом выделенном столбце Selection. Объединенные ячейки не мешают If TypeName(Selection) <> "Range" Then Exit Sub If Selection.Columns.Count <> 1 Then Intersect(Selection, Selection(1).EntireColumn).Select On Error Resume Next Application.ScreenUpdating = False Dim iCell As Range, MrgCls As Boolean Dim Nn: Nn = Selection(1) If Not IsNumeric(Nn) Then Nn = InputBox("Введите НОМЕР первого пункта", "В первой ячейке - текст!", 1) If Not IsNumeric(Nn) Then Exit Sub End If Nn = Int(Nn) If Nn = 0 Then Nn = 1 For Each iCell In Selection With iCell If (Not .MergeCells) Or (.MergeCells And .Address = .MergeArea.Cells(1).Address) Then .Value = Nn: Nn = Nn + 1 .NumberFormat = Selection(1).NumberFormat .HorizontalAlignment = Selection(1).HorizontalAlignment .VerticalAlignment = Selection(1).VerticalAlignment .Orientation = Selection(1).Orientation .ShrinkToFit = Selection(1).ShrinkToFit End If If .MergeCells Then MrgCls = True End With Next Application.ScreenUpdating = True End Sub
[/vba]
Всем добрый вечер! Появилась потребность постоянно нумеровать строки, при этом таблица динамичная, каждый день строки удаляются и добавляются. Протаскивать не получается, потому что встречаются строки которые нумеровать ненужно, так как они являются заголовками разделов. Нашёл макрос, но он нумерует все строки подряд. Есть идея сделать эти заголовки жёлтыми и прописать в макросе, чтобы нумеровались только белые строки. Подскажите как это сделать. Макрос прилагаю. [vba]
Код
Sub RowsNum() 'нумерация ячеек в первом выделенном столбце Selection. Объединенные ячейки не мешают If TypeName(Selection) <> "Range" Then Exit Sub If Selection.Columns.Count <> 1 Then Intersect(Selection, Selection(1).EntireColumn).Select On Error Resume Next Application.ScreenUpdating = False Dim iCell As Range, MrgCls As Boolean Dim Nn: Nn = Selection(1) If Not IsNumeric(Nn) Then Nn = InputBox("Введите НОМЕР первого пункта", "В первой ячейке - текст!", 1) If Not IsNumeric(Nn) Then Exit Sub End If Nn = Int(Nn) If Nn = 0 Then Nn = 1 For Each iCell In Selection With iCell If (Not .MergeCells) Or (.MergeCells And .Address = .MergeArea.Cells(1).Address) Then .Value = Nn: Nn = Nn + 1 .NumberFormat = Selection(1).NumberFormat .HorizontalAlignment = Selection(1).HorizontalAlignment .VerticalAlignment = Selection(1).VerticalAlignment .Orientation = Selection(1).Orientation .ShrinkToFit = Selection(1).ShrinkToFit End If If .MergeCells Then MrgCls = True End With Next Application.ScreenUpdating = True End Sub
Sub u_629() u_1 = Selection.Column If u_1 = 1 Then For Each u In Selection u_2 = u.Interior.Color If u_2 <> 65535 Then u_3 = u.Row If u_3 = 1 Then Range("a" & u_3) = 1 Else Range("a" & u_3) = Application.Max(Range("a1:a" & u_3 - 1)) + 1 End If End If Next Else MsgBox "Выделен не 1-й столбец" End If End Sub
[/vba]
Ну какой пример, такой и ответ [vba]
Код
Sub u_629() u_1 = Selection.Column If u_1 = 1 Then For Each u In Selection u_2 = u.Interior.Color If u_2 <> 65535 Then u_3 = u.Row If u_3 = 1 Then Range("a" & u_3) = 1 Else Range("a" & u_3) = Application.Max(Range("a1:a" & u_3 - 1)) + 1 End If End If Next Else MsgBox "Выделен не 1-й столбец" End If End Sub