Excel VBA Макросы: Перенос данных по условию из одного столбца в другой.

[М]

Подскажите, как можно все ячейки, содержащие слово «ткань», перенести с удалением из столбца В в столбец С?

[Администратор]

Нужно учитывать, что искомое слово может быть частью более длинного другого слова.
Например, "око" является частью "молоко".
Значит нужно не просто искать, а искать слово целиком.
Excel так не умеет искать, нужно делать дополнительные действия.

[М]

Ситуацию с "око" можно исключить. Это точно.

[Администратор]

1. Вверху модуля вставьте эти строки:
Option Explicit
Option Compare Text
Option Base 1

2. Макрос предполагает, что данные начинаются со строки 2 (т.е. строка 1 это шапка).

Макрос

Sub Макрос()
   
    Dim src(), res()
    Dim lr As Long, i As Long
   
   
    '1. Сбрасываем автофильтр, если он есть, иначе макрос не сможет вставить данные из массива.
    If ActiveSheet.AutoFilterMode = True Then
        ActiveSheet.AutoFilter.ShowAllData
    End If
   
    '2. Поиск последней строки в столбце B.
        ' End не ищет в скрытых строках.
    lr = Cells(Rows.Count, "B").End(xlUp).Row
   
    '3. Копирование данных из столбца B в массив.
        ' Данные копируются со строки 2 (подразумевается, что первая строка это шапка).
    src() = Range("B2:B" & lr).Value
   
    '4. Создание ячеек в массиве-результате.
    ReDim res(UBound(src), 1)
   
    '5. Перемещение ячеек, в которых есть слово "ткань" из массива "src" в массив "res".
    For i = 1 To UBound(src)
        ' Если в ячейке есть слово "ткань".
        If InStr(src(i, 1), "ткань") <> 0 Then
            ' Копирование данных из массива "src" в массив "res".
            res(i, 1) = src(i, 1)
            ' Очистка ячейки в массиве "src".
            src(i, 1) = Empty
        End If
    Next i
   
    '6. Вставка изменённых массивов на лист.
    Range("B2").Resize(UBound(src)).Value = src()
    Range("C2").Resize(UBound(res)).Value = res()
   
    '7. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

[свернуть]