Скопируйте диапазон, а не всю строку

Question

У меня есть код для сопоставления значений в столбце «B» со значением в ячейке «M15» и копирования и удаления этих строк.

Мне нужно только скопировать и удалить диапазон (от A до J) ине весь ряд.

Sub MoveRows()

Dim Sht1 As Worksheet, Sht3 As Worksheet
Dim tfRow As Range, C As Range 
Dim CopyRng As Range
Dim LastRow As Long

Application.ScreenUpdating = False

Set Sht1 = Sheets("Sheet1")
Set Sht3 = Sheets("Sheet3")
With Sht1
   LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row 

   Set tfRow = .Range("B2:B" & LastRow)

For Each C In tfRow

    If IsEmpty(C) Then
        Exit Sub
    End If

    If C.Value = .Range("M15").Value Then 
        If Not CopyRng Is Nothing Then
            Set CopyRng = Application.Union(CopyRng, C)   
        Else
            Set CopyRng = C
        End If
    End If

Next C
End With

If Not CopyRng Is Nothing Then

   LastRow = Sht3.Cells(Sht3.Rows.Count, "B").End(xlUp).Row
   CopyRng.EntireRow.Copy Destination:=Sht3.Range("A" & LastRow + 1)
   CopyRng.EntireRow.Delete (xlShiftUp)

End If

Answer 1

В приведенном ниже базовом коде используется автофильтр (гораздо быстрее, чем зацикливание), и копируются видимые ячейки в диапазоне в первую пустую ячейку в столбце A.

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

Dim ws1 As Worksheet, ws3 As Worksheet, lRow As Long, Rng As Range

Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws3 = ThisWorkbook.Sheets("Sheet3")
lRow = ws3.Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = ws1.Range("A1").CurrentRegion

    Rng.AutoFilter Field:=2, Criteria1:=ws1.Range("M15").Value

    ws1.Range(Cells(2, 1), Cells(Rng.Rows.Count, 10)).SpecialCells(xlCellTypeVisible).Copy _
    Destination:=ws3.Range("A" & lRow + 1)

    'You must clear the range and then remove the filter before deleting blank cells.
    ws1.Range(Cells(2, 1), Cells(Rng.Rows.Count, 10)).SpecialCells(xlCellTypeVisible).Clear
    ws1.Cells.AutoFilter
    ws1.Range(Cells(2, 1), Cells(Rng.Rows.Count, 10)).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp