При условии перенос строк из одного листа в другой

[Ilya_L]

Помогите пожалуйста
Имеется таблица
Ф | И | О | балл1 | балл2 | балл3 | сум |
Имеется такой код

Private Sub CommandButton3_Click()

Dim Fpath As String, FName As String:
Application.ScreenUpdating = False
FName = Split(TextBox7, "\")(UBound(Split(TextBox7, "\")))
Fpath = Replace(TextBox7, FName, "")
With Sheets("Список абитуриентов")
    With .Range(.Cells(2, 1), .Cells(301, 6))
        .ClearContents
        .FormulaR1C1 = "='" & Fpath & "[" & FName & "]Лист1'!R1C1:R301C6"
        .Value = .Value                            'Значение ячейки
        .Replace 0, "", xlWhole                    'заменять 0 на ""
    End With
End With

Application.ScreenUpdating = False
[G2].FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
[G2].AutoFill Destination:=[G2:G301]
[G2:G301].Value = [G2:G301].Value
[G2:G301].Replace 0, "", xlWhole

UserForm2.Hide

End Sub

который читает данные с таблицы и заносит эти данные в нашу таблицу. Нужно сделать так, чтобы когда в строке 2,3... в столбцах (балл1,балл2,балл3) находит хотя бы одну 2, то переносит эту строку в другой лист, при этом чтобы каждая строка 2 листа добавлялась, а в 1 листе не оставалось пустых строчек.

[SAS888]

Например, так:

Sub Main()
    Dim x As Range, y As Range, z As Range, fst As String: Application.ScreenUpdating = False
    Sheets(1).Activate: Sheets(2).Cells.ClearContents
    Set z = Range([D1], Cells(Rows.Count, 1).End(xlUp).Offset(, 5))
    Set x = z.Find(what:=2, LookAt:=xlWhole)
    If Not x Is Nothing Then
        fst = x.Address
        Do
            If y Is Nothing Then Set y = x Else Set y = Union(y, x)
            Set x = z.FindNext(x)
        Loop While fst <> x.Address
    End If
    If Not y Is Nothing Then
        y.EntireRow.Copy Sheets(2).Rows(1): y.EntireRow.Delete
    End If
End Sub

[Ilya_L]

Сообщение от SAS888

Например, так:

Sub Main()
    Dim x As Range, y As Range, z As Range, fst As String: Application.ScreenUpdating = False
    Sheets(1).Activate: Sheets(2).Cells.ClearContents
    Set z = Range([D1], Cells(Rows.Count, 1).End(xlUp).Offset(, 5))
    Set x = z.Find(what:=2, LookAt:=xlWhole)
    If Not x Is Nothing Then
        fst = x.Address
        Do
            If y Is Nothing Then Set y = x Else Set y = Union(y, x)
            Set x = z.FindNext(x)
        Loop While fst <> x.Address
    End If
    If Not y Is Nothing Then
        y.EntireRow.Copy Sheets(2).Rows(1): y.EntireRow.Delete
    End If
End Sub

а там можно сделать, чтобы не с 1 строки начиналось, а со 2, и, чтобы удалялась не вся строка, а только диапазон этой строки?

[SAS888]

Можно.
Говорите, что конкретно нужно.

[Ilya_L]

y.EntireRow.Delete
Эта часть кода удаляет всю строку..а мне нужно, чтобы удалились только часть строки, т.е. с 1 по 7 столбцы... Как это можно сделать?

[SAS888]

Удалить, например, со сдвигом вверх, можно так:

Intersect(y.EntireRow, [A:G]).Delete Shift:=xlUp