Страницы: 1
RSS
Макрос копирования строки на другой лист, если ячейка имеет значение отличное от 0
 
Добрый день.
Стоит следующая задача:
Необходимо копировать всю строку во второй лист, если в столбце "E" значение ячейки отлично от "0". в самой ячейке стоит формула, что пересчитывает столбец "D" на наличие пропуска цифр и выводит в ячейку E отсутствующие цифры или присваивает 0, если все в порядке. Если в столбце D, после значения "Всего" отсчет не начинается с 1 то же копировать на второй лист (желательно не перемешивая и сохраняя изначальный порядок).
На форуме куча постов по копированию с помощью макроса, однако без знания их тяжело подстраивать под мою (начал пробовать, но понял, что все плохо).
Просто в таблице порядка 900 тыс строк и обрабатывать ее вручную ну очень сложно.  
 
1) Оберните вашу формулу в функцию ЕСЛИОШИБКА(), чтобы формула возвращала 0 в случае ошибки, то есть вот так для ячейки E2
=ЕСЛИОШИБКА(ЕСЛИ(D3-D2=1;0;ЕСЛИ(D3-D2>=3;D2+1&" - "&D3-1;D2+1));0)
и протяните её ниже
2) Создайте в файле "Лист2" (в вашем примере нет такого листа)
3) Чуть поправил ваш код
Код
Sub Прямоугольник1_Щелчок()
Dim iLastRow As Long, rw As Long

    iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    rw = 1
    With Sheets("Лист2")
        For i = 1 To iLastRow
            If Cells(i, 5).Value > 0 Then
                Range(Cells(i, 1), Cells(i, 2)).Copy .Cells(rw, 1)
                rw = rw + 1
            End If
        Next
    End With
    
    MsgBox "Скопировано!", vbInformation, "Конец"
End Sub

P.S. Но что-то тут не так... с вашим копированием...  
Изменено: New - 20.11.2020 17:47:14
 
New,
Спасибо и на том. Ну да он слегка криво работает, тк макрос брался с другого проекта и я пытался подстроить под свой.
 
Максим Михайлов, еще вариант
Код
Sub dsd()
Dim arr, arr2, i As Long, n As Long, k As Long, lr As Long
With Worksheets("Лист1")
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    arr = .Range("A5:E" & lr)
    x = Application.WorksheetFunction.CountIfs(.Range("E5:E" & lr), 1)
    ReDim arr2(1 To x, 1 To 5)
    n = 1
    For i = LBound(arr) To UBound(arr)
        If arr(i, 5) = 1 Then
            For k = 1 To 5
                arr2(n, k) = arr(i, k)
            Next k
            n = n + 1
        End If
    Next i
End With
Worksheets("Лист2").Range("A1").Resize(UBound(arr2), 5) = arr2
Worksheets("Лист2").Select
End Sub
Не бойтесь совершенства. Вам его не достичь.
 
Mershik,
Спасибо
Страницы: 1
Наверх