Новости:

Теперь на форум можно залогиниться / зарегистрироваться с помощью ВКонтакте. Уже существующие пользователи могут связать свою учетную запись с аккаунтом ВКонтакте одним кликом в профиле пользователя http://forum.msexcel.ru/index.php?action=profile;area=account

Главное меню

Автонумерация в левом столбце при вводе данных в правом столбце с помощью VBA

Автор bsi, 30.05.2016, 13:49

« назад - далее »

bsi

Здравствуйте, уважаемые форумчане. Несколько дней искал на различных форумах ответ на свой вопрос, но то, что мне нужно, так и не нашел. Необходимо средствами VBA осуществить следующее. В столбце А, после ввода данных в столбце B, получаем нумерацию строк, но если удалить данные в некоторых строках столбца В, нумерация в А должна меняться и быть только там, где имеются данные в В. С помощью формул вопрос решаем, но хотелось бы с помощью VBA. Пример во вложении. Всем спасибо.

cheshiki1

в модуль листа
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i, m(), a(), n#, ii#, R
If Target.Cells.Count > 1 Then Exit Sub 'если выделено больше одной ячейки то выход
If Intersect(Range("B6:B1000"), Target) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
R = WorksheetFunction.Max(Target.Row, Cells(Rows.Count, 2).End(xlUp).Row)
a = Range("B6:B" & R).Value
ReDim m(1 To UBound(a))
For Each i In a
  If i <> "" Then
   n = n + 1: m(n) = ii + 1: ii = ii + 1
  Else
   n = n + 1
  End If
Next
Application.EnableEvents = False
Range("A6").Resize(UBound(m), 1) = WorksheetFunction.Transpose(m)
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

kuklp1

Вообще-то условия автора выполняются проще:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Or Target.Column <> 2 Then Exit Sub
    If Target = "" Then Target(1, 0) = "" Else Target(1, 0) = Application.Max([a:a]) + 1
End Sub
;)
Я, как всегда, чертовски адекватен... Email: kuklp60@gmail.com WM Z206653985942, R334086032478, U238399322728, E332314026771

bsi

Спасибо за быстрые ответы. Код кодcheshiki1 прекрасно подходит, но если начинать ввод данных с 6-ой строки, то выскакивает ошибка № 13, потом идет все нормально и при удалении данных в не которых ячейках столбца В нумерация по порядку изменяется в соответствии с имеющимися данными в столбце В.
Код следующего сообщения нумерацию проставляет с самого начала без ошибок, но после удаления данных в некоторых ячейках столбца В остается в прежнем порядке.

bsi

В первом коде при вводе данных в шестой строке ругается на a = Range("B6:B" & R).Value

kuklp1

Чуток оптимизировал код cheshiki1 ;)
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i&, a(), n&
    If Target.Cells.Count > 1 And Target.Column <> 2 Then Exit Sub
    a = Range("a6:B" & Cells(Rows.Count, 2).End(xlUp).Row).Value
    For i = 1 To UBound(a)
        If a(i, 2) <> "" Then n = n + 1: a(i, 1) = n Else a(i, 1) = ""
    Next
    Range("A6").Resize(UBound(a), 2) = a
End Sub
Я, как всегда, чертовски адекватен... Email: kuklp60@gmail.com WM Z206653985942, R334086032478, U238399322728, E332314026771

bsi

Уважаемый, kuklp1, все прекрасно работает. Единственная просьба, если есть конечно такая возможность, изменить код так, чтобы при удалении строки в диапазоне где есть данные, происходило изменение нумерации.

Pelena

У меня так получилось
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Or Target.Column <> 2 Then Exit Sub
    For Each c In Range("A6:A" & Cells(Rows.Count, 2).End(xlUp).Row)
        If c.Offset(, 1) = "" Then c.Value = "" Else c.Value = Application.CountA(Range("B6:B" & c.Row))
    Next
End Sub

bsi

Pelena, спасибо за участие и быстрый ответ, но хотелось бы еще, чтобы при удалении строки внутри заполненного диапазона, происходил пересчет нумерации расположенной ниже удаленной строки.

Pelena

Событие WorkSheet_Change не отслеживает удаление строки.
Как вариант повесьте макрос на кнопку

bsi