Перемещение строк с использованием критериев "содержит"

#excel #vba

Вопрос:

Я создал макрос для перемещения строк информации на новые листы на основе определенных критериев.

Все они работают, однако последнему необходимо извлечь все, что «содержит» текст.

Это то, что я написал, но это не работает. Помогите?

Текущий код:

 Dim r As Range
Dim i As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("Sheet1")
Set Target = ActiveWorkbook.Worksheets("Sheet2")
i = 2
For Each r In Source.Range("E1:E3000")
    If r = "=*Wavelengths*" Then
        Source.rows(r.Row).Cut Target.rows(i)
        i = i   1
    End If
Next r

1. If r LIKE "*=Wavelengths*" Then Для сравнения по шаблону вам нужен оператор Like .

2. Кроме того, дважды проверьте, действительно ли вы = в =Wavelenghts . Может быть точным, но выглядит странно для ввода текста в Excel.

Ответ №1:

Используйте функцию instr, чтобы вернуть позицию, в которой строка находится внутри другой. Проверьте комментарии внутри кода, чтобы найти объяснения поведения.

Для дополнительной справки: https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/instr-function

Попробуйте этот код:

 Sub MoveRowsIfContains()

    Dim r As Range
    Dim i As Integer

    Dim Source As Worksheet
    Dim Target As Worksheet

    ' Speed up things
    Application.ScreenUpdating = False

    Set Source = ActiveWorkbook.Worksheets("Sheet1")
    Set Target = ActiveWorkbook.Worksheets("Sheet2")

    ' Beginning row 2 of target worksheet
    i = 2

    For Each r In Source.Range("E1:E3000")
        ' Check if string is in cell
        If InStr(1, r, "Wavelengths", vbTextCompare) > 0 Then ' --> The instr function. If you add the last parameter as "vbBinaryCompare" function is case sensitive, and "vbTextCompare" is case insensitive
            ' Copy the row to target
            Source.Rows(r.Row).EntireRow.Copy Target.Rows(i)
            ' Clean the source row (prevent cells from moving up)
            Source.Rows(r.Row).Clear
            i = i   1
        End If
    Next r

    ' Back to screen updating
    Application.ScreenUpdating = True

End Sub

1. В этом коде не следует проверять строки после каждого вырезания. Возможно, вам захочется начать поиск снизу, что означает Source.Cells(Source.Rows.Count, "E").End(xlUp) . Вам нужно было бы заменить For Each r цикл, который вместо этого подсчитывает строки.

2. @Variatus вы правы. Спасибо за предупреждение. Я предоставил альтернативу копирования / очистки исходных строк. Может быть полезно в некоторых случаях.

Ответ №2:

Вы могли бы попробовать:

 Option Explicit

Sub test()

    With ThisWorkbook

        Dim rng As Range, cell As Range
        Dim i As Long
        Dim Source As Worksheet, Target As Worksheet

        Set Source = .Worksheets("Sheet1")
        Set Target = .Worksheets("Sheet2")
        Set rng = Source.Range("E1:E3000")

        i = 2

        For Each cell In rng

            If InStr(1, cell.Value, "Wavelengths") > 0 Then

                Source.Rows(cell.Row).Cut Target.Rows(i)
                i = i   1

            End If

        Next cell

    End With

End Sub

Примечание:

Если вы хотите удалить пустую строку после вырезания — вставки, вам следует перебирать строки снизу вверх, используя:

 For i=Lastrow to ... step -1
Next i