как вставить в следующую пустую ячейку справа?

Question

Я пытаюсь скопировать значения из соответствующих значений ячейки со смещением и прошлым значением в следующую пустую ячейку справа. Я получаю сообщение об ошибке "Несоответствие типов"

Dim ThisCell1 As Range
Dim ThisCell2 As Range
Dim LCol As Long
  Application.ScreenUpdating = False
  For Each ThisCell1 In Sheets("sheet1").Range("A1:A1089")
        For Each ThisCell2 In Sheets("sheet0").Range("b2:b3392")
            If ThisCell2.Value = ThisCell1.Value Then

                ThisCell2.Offset(0, 1).Copy

                ThisCell1.End(xlToLeft).Offset(0, 1).Select
                Selection.PasteSpecial Paste:=xlPasteValues
                Exit For
                End If
            Next ThisCell2
            Next ThisCell1
Application.ScreenUpdating = True

Answer 1

Этот саб делает то, что вам нужно, и будет намного быстрее, чем при использовании двойной петли, которую вы используете. Он использует формулу Match в качестве аргумента, который определяет, по какой строке найдено совпадение. Затем он перейдет к этой строке, найдет последний использованный столбец и скопирует смещение исходной строки:

Dim ThisCell1 As Range
Dim ThisCell2 As Range
Dim LCol As Long
  Application.ScreenUpdating = False
        For Each ThisCell2 In Sheets("sheet0").Range("b2:b3392")
            If Not IsError(Application.Match(ThisCell2.Value, Sheets("Sheet1").Range("A1:A1089"))) Then
                    Sheets("Sheet1"). Cells(Application.Match(ThisCell2.Value, Sheets("Sheet1").Range("A1:A1089")), Columns.Count).End(xlToLeft).Offset(, 1).Value = ThisCell2.Offset(, 1)
                Exit For 'This insures you only ever get one match. Is that what is needed?
                End If
            Next ThisCell2
Application.ScreenUpdating = True

Я не уверен, что это именно та логика, которую вы искали, если нетдайте мне знать. Это самое близкое приближение, которое я мог бы найти к вашему исходному коду, сравнивая ваше значение с диапазоном.