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

Question

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

Все они работают, однако последний должен извлекать все, что "содержит" текст.

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

Текущий код:

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

Answer 1

Вы можете попробовать:

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

Answer 2

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

Для дальнейшего ознакомления: https://docs.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