Как быстро переместить элементы между двумя списками в Excel?

Пытались ли вы когда-нибудь переместить элементы из одного списка в другой, как показано на скриншоте ниже? Здесь я расскажу об этой операции в Excel.

Перемещение элементов между списками

Перемещение элементов между списками

Нет встроенной функции, которая может помочь вам завершить задачу, но у меня есть код VBA, который может помочь.

1. Сначала вам нужно создать список данных, который будет отображаться как элементы в списках на новом листе под названием Admin_Lists.

2. Затем выберите эти данные и перейдите в поле Имя, чтобы дать им имя ItemList. Смотрите скриншот:

3. Затем на листе, который будет содержать два списка, нажмите Разработчик > Вставить > Поле со списком (Элемент управления ActiveX) и нарисуйте два списка. Смотрите скриншот:

Если вкладка Разработчик скрыта на вашей ленте, Как показать/отобразить вкладку разработчика в ленте Excel 2007/2010/2013? Эта статья расскажет вам, как это сделать.

4. Затем нажмите Разработчик > Вставить > Кнопка команды (Элемент управления ActiveX) и нарисуйте четыре кнопки между двумя списками. Смотрите скриншот:

Теперь переименуйте четыре кнопки команд с новыми именами.

5. Выберите первую кнопку команды, нажмите Свойства, и в панели Свойства присвойте ей имя BTN_moveAllRight и введите >> в текстовое поле рядом с Надпись. Смотрите скриншот:

6. Повторите шаг 5 для переименования последних трех кнопок команд с указанными ниже именами и также введите различные стрелки в подписи. Смотрите скриншот:

BTN_MoveSelectedRight

BTN_moveAllLeft

BTN_MoveSelectedLeft

7. Щелкните правой кнопкой мыши по имени листа, содержащего списки и кнопки команд, и выберите Просмотр кода из контекстного меню. Смотрите скриншот:

8. Скопируйте и вставьте макрос-код ниже в модульный скрипт, затем сохраните код и закройте окно Microsoft Visual Basic for Applications. Смотрите скриншот.

VBA: Перемещение элементов между двумя списками

Private Sub Worksheet_Activate()
'UpdatebyExtendoffice20171117
    Dim xCell As Range
    Dim xRg As Range
    Set xRg = Sheets("Admin_Lists").Range("ItemList")
    Me.ListBox1.Clear
    Me.ListBox2.Clear
    With Me.ListBox1
        .LinkedCell = ""
        .ListFillRange = ""
        For Each xCell In xRg
            If xCell <> "" Then
                .AddItem xCell.Value
            End If
        Next xCell
    End With
    Me.ListBox1.MultiSelect = fmMultiSelectMulti
    Me.ListBox2.MultiSelect = fmMultiSelectMulti
End Sub

Private Sub BTN_MoveSelectedLeft_Click()
    Call moveSigle(Me.ListBox2, Me.ListBox1)
End Sub

Private Sub BTN_MoveSelectedRight_Click()
    Call moveSigle(Me.ListBox1, Me.ListBox2)
End Sub

Private Sub BTN_moveAllLeft_Click()
    Call moveAll(Me.ListBox2, Me.ListBox1)
End Sub

Private Sub BTN_moveAllRight_Click()
    Call moveAll(Me.ListBox1, Me.ListBox2)
End Sub

Sub moveAll(xListBox1 As Object, xListBox2 As Object)
    Dim I As Long
    For I = 0 To xListBox1.ListCount - 1
        xListBox2.AddItem xListBox1.List(I)
    Next I
    xListBox1.Clear
End Sub

Sub moveSigle(xListBox1 As Object, xListBox2 As Object)
    Dim I As Long
    For I = 0 To xListBox1.ListCount - 1
        If I = xListBox1.ListCount Then Exit Sub
        If xListBox1.Selected(I) = True Then
            xListBox2.AddItem xListBox1.List(I)
            xListBox1.RemoveItem I
            I = I - 1
        End If
    Next
End Sub

9. Затем перейдите на другой лист, а затем вернитесь к листу, содержащему списки. Теперь вы можете видеть, что данные списка отображаются в первом списке. Нажмите на кнопки команд, чтобы перемещать элементы между двумя списками.

Переместить выбор

Переместить все