Копировать и удалить выбранный элемент списка - PullRequest
Новая
       6

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

0 голосов
/ 02 января 2019

У меня есть код, который:

  1. UserForm1 Listbox 1 заполняет свой элемент из Worksheet1
  2. UserForm2 содержит текстовые поля и кнопку отправки
  3. Когда я выбираю элемент из UserBorm1 ListBox1, он копирует значения в текстовые поля UserForm2

Я хочу, чтобы, когда я захожу в UserForm 2 и нажимаю кнопку отправки, строка из Worksheet1 перемещалась в Worksheet2

Ниже приведен код внутри пользовательской формы ListBox1 

Private Sub UserForm1ListBox1_Click()
    With UserForm2
        .TextBox1 = ListBox1.Column(0)
        .TextBox2 = ListBox1.Column(1)
        .TextBox3 = ListBox1.Column(2)
        .TextBox4 = ListBox1.Column(3)
        .TextBox5 = ListBox1.Column(4)
    End With
End Sub

Ниже приведен код внутри кнопки отправки UserForm2. Получение ошибки комментируется в коде. 

Private Sub Userform2SubmitButton_Click() 
    Dim i As Long

    For i = UserForm1.ListBox1.ListCount - 1 To 0 Step -1
        If UserForm1.ListBox1.Selected(i) Then

            Worksheets("Worksheet1").Range("A" & i + 1). _
            Copy Worksheets("Worksheet2").Range("A" & Rows.Count).End(xlUp).Offset(0)

            If UserForm1.ListBox1.ListIndex >= 0 Then
            LastRow = Worksheets("Worksheet1").Cells(Rows.Count, "A").End(xlUp).Row

            Worksheets("Worksheet1").Range("A" & LastRow).Find(what:=UserForm1.ListBox1.Value, LookIn:=xlValues, LookAt:=xlWhole).Activate   '<------------------error here!
            Worksheets("Worksheet1").Rows(ActiveCell.Row).Delete

        End If
     End If
    Next i
End Sub

Ответы [ 2 ]

0 голосов
/ 03 января 2019

Мне удалось выяснить, чего не хватало.Все это время было просто 

Sheets("Worksheet1").Select

Я добавил это к своему исходному коду для тех, кто хочет использовать это также.Спасибо SJR за вашу помощь. 

Private Sub Userform2SubmitButton_Click() 
    Dim i As Long
    Sheets("Worksheet1").Select
    For i = UserForm1.ListBox1.ListCount - 1 To 0 Step -1
        If UserForm1.ListBox1.Selected(i) Then

            Worksheets("Worksheet1").Range("A" & i + 1). _
            Copy Worksheets("Worksheet2").Range("A" & Rows.Count).End(xlUp).Offset(0)

            If UserForm1.ListBox1.ListIndex >= 0 Then
            LastRow = Worksheets("Worksheet1").Cells(Rows.Count, "A").End(xlUp).Row

            Worksheets("Worksheet1").Range("A" & LastRow).Find(what:=UserForm1.ListBox1.Value, LookIn:=xlValues, LookAt:=xlWhole).Activate   '<------------------error here!
            Worksheets("Worksheet1").Rows(ActiveCell.Row).Delete

        End If
     End If
    Next i
    End Sub
0 голосов
/ 02 января 2019

Что-то в этом роде.Оставил несколько комментариев / запросов в коде, так как не уверен насчет нескольких вещей.Обратите внимание, как обрабатывать возможность Find не найти ничего. 

Private Sub Userform2SubmitButton_Click()

Dim i As Long, r As Range, ws As Worksheet

Set ws = Worksheets("Worksheet1")

For i = UserForm1.ListBox1.ListCount - 1 To 0 Step -1
    If UserForm1.ListBox1.Selected(i) Then
        ws.Range("A" & i + 1).Copy _
              Worksheets("Worksheet2").Range("A" & Rows.Count).End(xlUp).Offset(1) 'changed offset to 1 so as not to overwrite
        If UserForm1.ListBox1.ListIndex >= 0 Then
            LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row 'not sure what this is for
            Set r = ws.Cells.Find(what:=UserForm1.ListBox1.Value, LookIn:=xlValues, LookAt:=xlWhole)
            If Not r Is Nothing Then 'avoid error if nothing found
                r.EntireRow.Delete
            End If
        End If
    End If
Next i

End Sub
...