Как перенести отдельные данные из одного листа Excel на другой?
На панели "Разработчик" есть кнопка "Запись макроса":
 - жмакаете на нее;
 - делаете необходимые процедуры (перемещение\удаление слов);
 - останавливаете запись;
 - смотрите получившийся код;
 - удаляете лишнее. добавляете необходимое.
Не совсем понятно как будут программно отбираться слова?UpD (вот что получилось у меня):Private Sub CommandButton1_Click()
    Dim key_word As String ' ключевое слово, по которому будем отбирать
    Dim i, count As Integer
        
    key_word = TextBox1.Text
    Sheets("Лист1").Select
    count = 0
    i = 1
    While (Cells(i, 1) <> "") ' проходим до первой пустой ячейки столбец А '
        If (InStr(1, LCase(Cells(i, 1)), LCase(key_word), vbBinaryCompare) > 0) Then ' если совпало '
            count = count + 1
            Cells(i, 1).Select
            Selection.Cut ' вырезаем из Лист1 '
            Sheets("Лист2").Select
            Cells(count, 1).Select
            ActiveSheet.Paste ' вставляем в Лист2 '
            Sheets("Лист1").Select
        End If
        i = i + 1
    Wend
    Label1.Caption = "find: " & count
    
    i = i - 1
    While (i > 0)
        If (Cells(i, 1) = "") Then
            Cells(i, 1).Select
            Selection.Delete Shift:=xlUp ' в Лист1 удаляем все пустые ячейки со сдвигом вверх '
        End If
        i = i - 1
    Wend
End Sub
На панели "Разработчик" есть кнопка "Запись макроса":
 - жмакаете на нее;
 - делаете необходимые процедуры (перемещение\удаление слов);
 - останавливаете запись;
 - смотрите получившийся код;
 - удаляете лишнее. добавляете необходимое.
Не совсем понятно как будут программно отбираться слова?UpD (вот что получилось у меня):Private Sub CommandButton1_Click()
    Dim key_word As String ' ключевое слово, по которому будем отбирать
    Dim i, count As Integer
        
    key_word = TextBox1.Text
    Sheets("Лист1").Select
    count = 0
    i = 1
    While (Cells(i, 1) <> "") ' проходим до первой пустой ячейки столбец А '
        If (InStr(1, LCase(Cells(i, 1)), LCase(key_word), vbBinaryCompare) > 0) Then ' если совпало '
            count = count + 1
            Cells(i, 1).Select
            Selection.Cut ' вырезаем из Лист1 '
            Sheets("Лист2").Select
            Cells(count, 1).Select
            ActiveSheet.Paste ' вставляем в Лист2 '
            Sheets("Лист1").Select
        End If
        i = i + 1
    Wend
    Label1.Caption = "find: " & count
    
    i = i - 1
    While (i > 0)
        If (Cells(i, 1) = "") Then
            Cells(i, 1).Select
            Selection.Delete Shift:=xlUp ' в Лист1 удаляем все пустые ячейки со сдвигом вверх '
        End If
        i = i - 1
    Wend
End Sub