Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
автопереход с следующему столбцу в таблице
 
#1
09.04.2026 18:28:56
Добрый вечер. Возможно ли такое осуществить: в умной таблице в столбец вводятся числа, как только введенное число повторяется, оно переносится в начало следующего столбца, и ввод продолжается до следующего повтора. Более наглядно попытался объяснить в прикрепленном файле.
 
 
 
#2
09.04.2026 18:49:24
А если Вы введете дубликат где-то внутри столбца? ДО последней строки? Тоже переходим на новый круг?
Если достигнут последний столбец Таблицы куда переходить? Создавать новый?
Согласие есть продукт при полном непротивлении сторон
 
 
 
#3
09.04.2026 19:07:37
Цитата
написал:
А если Вы введете дубликат где-то внутри столбца? ДО последней строки? Тоже переходим на новый круг?Если достигнут последний столбец Таблицы куда переходить? Создавать новый?
Первый круг по идее самый большой по количеству строк, но есть вероятность что кто-то застрял на старте и второй или третий круг может получиться самый большой. если внутри столбца Да, переходим на новый круг. круги сделаны с запасом, вероятность что закончатся есть, но очень маленькая. единственное что последний круг придется мышкой перенести на "финиш"
 
 
 
#4
10.04.2026 10:27:49
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If IsError(Target.Value) Then Exit Sub
    If IsEmpty(Target.Value) Then Exit Sub
    
    If WorksheetFunction.CountIfs(Target.EntireColumn.Resize(Target.Row), Target.Value) > 1 Then
        Cells(3, Target.Column + 1).Select
    End If
End Sub
Вставьте код в модуль листа.
Правый клик на ярлычке листа - Исходный текст
 
 
 
#5
10.04.2026 10:32:39
Вариант для умных таблиц.
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If IsError(Target.Value) Then Exit Sub
    If IsEmpty(Target.Value) Then Exit Sub
    
    Dim tb As ListObject
    On Error Resume Next
    Set tb = Target.ListObject
    On Error GoTo 0
    If tb Is Nothing Then
        If WorksheetFunction.CountIfs(Target.EntireColumn.Resize(Target.Row), Target.Value) > 1 Then
            Cells(3, Target.Column + 1).Select
        End If
    Else
        If WorksheetFunction.CountIfs(Intersect(Target.EntireColumn.Resize(Target.Row), tb.DataBodyRange), Target.Value) > 1 Then
            Intersect(Target.Cells(1, 2).EntireColumn, tb.DataBodyRange.Rows(1)).Select
        End If
    End If
End Sub
 
 
 
#6
10.04.2026 14:15:30
Большое спасибо, а возможно что бы это число ввелось вначале нового столбца сразу?
 
 
 
#7
10.04.2026 14:20:28
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If IsError(Target.Value) Then Exit Sub
    If IsEmpty(Target.Value) Then Exit Sub
     
    Dim tb As ListObject
    On Error Resume Next
    Set tb = Target.ListObject
    On Error GoTo 0
    If tb Is Nothing Then
        If WorksheetFunction.CountIfs(Target.EntireColumn.Resize(Target.Row), Target.Value) > 1 Then
            SelectTargetCell Target, Cells(3, Target.Column + 1)
        End If
    Else
        If WorksheetFunction.CountIfs(Intersect(Target.EntireColumn.Resize(Target.Row), tb.DataBodyRange), Target.Value) > 1 Then
            SelectTargetCell Target, Intersect(Target.Cells(1, 2).EntireColumn, tb.DataBodyRange.Rows(1))
        End If
    End If
End Sub

Private Sub SelectTargetCell(sourceRange As Range, targetRange As Range)
    targetRange.Select
    targetRange.Value = sourceRange.Value
End Sub
 
 
 
#8
10.04.2026 14:28:01
Можно чтобы число в конце столбца не оставалось?
 
 
 
#9
10.04.2026 14:28:23
внизу столбца не оставалось
 
 
 
#10
10.04.2026 14:30:35
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If IsError(Target.Value) Then Exit Sub
    If IsEmpty(Target.Value) Then Exit Sub
      
    Dim tb As ListObject
    On Error Resume Next
    Set tb = Target.ListObject
    On Error GoTo 0
    If tb Is Nothing Then
        If WorksheetFunction.CountIfs(Target.EntireColumn.Resize(Target.Row), Target.Value) > 1 Then
            SelectTargetCell Target, Cells(3, Target.Column + 1)
        End If
    Else
        If WorksheetFunction.CountIfs(Intersect(Target.EntireColumn.Resize(Target.Row), tb.DataBodyRange), Target.Value) > 1 Then
            SelectTargetCell Target, Intersect(Target.Cells(1, 2).EntireColumn, tb.DataBodyRange.Rows(1))
        End If
    End If
End Sub
 
Private Sub SelectTargetCell(sourceRange As Range, targetRange As Range)
    targetRange.Select
    targetRange.Value = sourceRange.Value
    sourceRange.Value = Empty
End Sub
 
 
 
#11
12.04.2026 08:21:44
Ещё раз спасибо
 
 
 
#12
18.04.2026 11:58:48
Добрый день .Как сделать автоперевод курсора на следующую ячейку?
Изменено: leshei - 18.04.2026 12:41:17
 
 
 
#13
18.04.2026 13:11:24
Отвечу сам себе:

Cells(ActiveCell.Row + 1, ActiveCell.Column).Select
 
 
 
#14
18.04.2026 17:46:48
Код
ActiveCell.Offset(1).Select
Согласие есть продукт при полном непротивлении сторон
 
 
 
#15
18.04.2026 18:42:25
Цитата
написал:
1ActiveCell.Offset(1).Select
Спасибо, насколько корректно мое решение (пример нашел)?  
 
 
 
#16
20.04.2026 09:40:19
Цитата
написал:
насколько корректно мое решение?  
Вариант рабочий, ничем не хуже.
Но если уж копать поглубже, то при использовании
Cells(ActiveCell.Row + 1, ActiveCell.Column)
Вы два раза обращаетесь к диапазону ActiveCell - сначала ActiveCell.Row, потом ActiveCell.Column.
При использовании
ActiveCell.Offset(1)
обращаетесь к диапазону один раз. Таким образом использование .Offset в два раза быстрее. Правда, разницу в этой задаче не увидите - вряд ли Вы намерены заполнить руками миллион ячеек.
 
 
 
Страницы: 1
Читают тему
Наверх