Перемещение определенных данных ячейки в другую ячейку

Question

Я пытаюсь переместить определенные данные «1» и «2» из одной ячейки в другую, и у меня возникают проблемы с кодом.Данные ячейки перемещаются, но я продолжаю получать «ложь» вместо перемещения данных.Кто-нибудь может мне помочь?Спасибо!

Sub tested()
    Dim rng As Range
    Dim lrow As Integer, irow As Integer

    With ActiveSheet
        lrow = .Range("A" & Rows.Count).End(xlUp).row

        For Each rng In .Range("A1:A" & lrow)
            If InStr(rng.Value, "1") > 0 Then
                rng.Offset(0, 1).Value = rng.Value = rng.Value = ""
            End If
        Next rng

        irow = .Range("A" & Rows.Count).End(xlUp).row

        For Each rng In .Range("A1:A" & lrow)
            If InStr(rng.Value, "2") > 0 Then
                rng.Offset(0, 2).Value = rng.Value = rng.Value = ""
            End If
        Next rng
    End With

Answer 1

Отрегулируйте строки, где у вас есть это:

rng.Offset(0, 1).Value = rng.Value = rng.Value = ""

на это

rng.Offset(0, 1).Value = rng.Value

Новый код:

Sub tested()

    Dim rng As Range
    Dim lrow As Integer, irow As Integer

    With ActiveSheet

        lrow = .Range("A" & Rows.Count).End(xlUp).Row

        For Each rng In .Range("A1:A" & lrow)

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

                rng.Offset(0, 1).Value = rng.Value
                rng.ClearContents

            ElseIf InStr(rng.Value, "2") > 0 Then

                rng.Offset(0, 2).Value = rng.Value
                rng.ClearContents

            End If

        Next rng

    End With

End Sub