Автозаполнение ячеек.

[Serg113]

Добрый день всем.

Подскажите пожалуйста, может кто сталкивался с такой бедой:

У меня в колонке есть ячейки объединенные и не объединенные. Хочу их пронумеровать автозаполнением, но как только доходит до объединенной ячейки программа выдает сообщение "Для этого требуется, чтоб ячейки имели одинаковый размер". У меня строк в документе около 20000, в ручную проставлять - как то печально. Может кто подскажет что делать, чтоб ускорить процесс?

Заранее большое спасибо.

[IgorGO]

подсказываю - напишите макрос

[Serg113]

А нет ли готового макроса, а то я далек от написания макросов?

[IgorGO]

человечеством написаны миллиарды готовых макросов.
например вот удивительный макрос, который нумерует строки

Sub NumRows()
  Dim r As Long
  r = Val(InputBox("Укажите число", "А сколько строк пронумеровать?", 123)):  Randomize
  if r >= 1 then Cells(1, 1 + Int(Rnd() * 20)).Resize(r, 1).Formula = "=row()"
End Sub

[SAS888]

Выделите ячейки в столбце, которые требуется пронумеровать и запустите макрос:

Sub NumCellsInColumn()
    Dim i As Long, j As Long: j = 1: Application.ScreenUpdating = False
    With Selection
        .Cells(1, 1) = 1
        For i = 2 To .Count
            If Intersect(.Cells(i, .Column), .Cells(i - 1, .Column).MergeArea) Is Nothing Then
                j = j + 1: .Cells(i, .Column) = j
            End If
        Next
    End With
End Sub

[Serg113]

Большое спасибо, Все получилось.
Это значительно облегчает жизнь.
Можно еще нескромный вопрос? А можно ли нумерацию задавать самому?

[IgorGO]

уверен, что использовался макрос SAS888

Sub NumCellsInColumn()
    Dim i As Long, j As Long:  Application.ScreenUpdating = False
    j = Val(InputBox("Укажите число", "Задайте начальный номер.", 1))  
    With Selection
        .Cells(1, 1) = j
        For i = 2 To .Count
            If Intersect(.Cells(i, .Column), .Cells(i - 1, .Column).MergeArea) Is Nothing Then
                j = j + 1: .Cells(i, .Column) = j
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub

я поправлю чуть-чуть с молчаливого позволения SAS888

[Serg113]

Большое спасибо за модернизацию. То что доктор прописал. Тему считаю закрытой. Вы мне очень помогли.