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

[CHIPATAM]

Всем доброго времени суток. Стоит следующая задача, нужно провести проверку по столбцу, если значения в них будут больше 0, то вся эта строка должна копироваться в другую книгу. Помогите пожалуйста с макросом

[staniiislav]

для работы примера, второй фаил должен быть открыт!

Sub ПереносВидимыхСтрок()
    Dim i As Long
    Application.ScreenUpdating = False
    On Error Resume Next
        With ThisWorkbook.ActiveSheet
            i = .Cells(Rows.Count, 1).End(xlUp).Row
            If .AutoFilter.Filters(1).On Then
                .Range("A1:A" & i).AutoFilter Field:=1, Criteria1:="<>"
                .Range("A1:A" & i).SpecialCells(xlCellTypeVisible).EntireRow.Copy Workbooks("Книга 2.xlsx").Sheets("Лист1").Range("A1")
                .Range("A1:A" & i).AutoFilter = False
            Else
                .Range("A1:A" & i).AutoFilter Field:=1, Criteria1:="<>"
                .Range("A1:A" & i).SpecialCells(xlCellTypeVisible).EntireRow.Copy Workbooks("Книга 2.xlsx").Sheets("Лист1").Range("A1")
                .Range("A1:A" & i).AutoFilter Field:=1
            End If
        End With
    Application.ScreenUpdating = True
End Sub

[staniiislav]

можно еще так:

Sub пример2()
Dim x, i As Long, n As Long
x = Range("A1").CurrentRegion.Value
For i = 1 To UBound(x, 1)
    If Not IsEmpty(x(i, 1)) Then
        n = n + 1
        x(n, 1) = x(i, 1): x(n, 2) = x(i, 2): x(n, 3) = x(i, 3)
    End If
Next i
Workbooks("Книга 2.xlsx").Sheets("Лист1").Range("A1").Resize(n, 3).Value = x
End Sub

[staniiislav]

еще один вариант:

Sub пример3()
Dim x, i&, t()

With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
        x = Range("A1").CurrentRegion.Value
        For i = 1 To UBound(x)
            If Not IsEmpty(x(i, 1)) Then
                If Not .Exists(x(i, 1)) Then
                    .Item(x(i, 1)) = Array(x(i, 1), x(i, 2), x(i, 3))
                End If
            End If
        Next
        
    x = Application.Transpose(Application.Transpose(.Items))
    Workbooks("Книга 2.xlsx").Sheets("Лист1").Range("A1").Resize(UBound(x), 3).Value = x
End With

End Sub

[Hugo121]

Второй вариант хороший - используется исходный массив, экономия памяти.

Последний вариант интересный, я такого не видел
Но там не совсем соблюдаются исходные условия:
1 нет проверки на >0
2 копируются данные только первого встреченного уникального значения первого столбца, т.е. повторы будут игнорироваться.
Ну и напрягает двойное Transpose - на больших объёмах как-то неоптимально, да и вообще на больших может не сработать.
Тогда уж быстрее и надёжнее просто в цикле переложить данные в двумерный массив.

[DiemonStar]

Такой вариант должен чуть быстрее работать:

Sub Макрос1()
  НомерСтолбцаПроверки = 1
  Application.ScreenUpdating = False
  Set R = [A1].Resize(Range("A" & Rows.Count).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column)
  [1:3].Insert Shift:=xlDown
  [4:4].Copy [A1]
  Cells(2, НомерСтолбцаПроверки) = ">0"
  R.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Intersect([1:2], R.EntireColumn), CopyToRange:=Range("Лист2!A1")
  [1:3].Delete Shift:=xlUp
  Application.ScreenUpdating = True
End Sub

[staniiislav]

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

Второй вариант хороший - используется исходный массив, экономия памяти.

Последний вариант интересный, я такого не видел
Но там не совсем соблюдаются исходные условия:
1 нет проверки на >0
2 копируются данные только первого встреченного уникального значения первого столбца, т.е. повторы будут игнорироваться.
Ну и напрягает двойное Transpose - на больших объёмах как-то неоптимально, да и вообще на больших может не сработать.
Тогда уж быстрее и надёжнее просто в цикле переложить данные в двумерный массив.

спасибо за пояснение, да немного перемудрил, кто-то на форуме делал что-то подомное, воя примерчик и сохранил, к сожалению нет манеры подписывать когда и кто делал пример (((

в таком случаи получится тоже самое что и второй вариант, только в прифи )))

я правильно Вас понял?:

Sub пример3()
Dim x, i&, j&, n As Long

'With CreateObject("Scripting.Dictionary")
'    .CompareMode = 1
        x = Range("A1").CurrentRegion.Value
        For i = 1 To UBound(x, 1)
            If Not IsEmpty(x(i, 1)) Then
            n = n + 1
                For j = 1 To UBound(x, 2)
                    x(n, j) = x(i, j)
                'If Not .Exists(x(i, 1)) Then
                '    .Item(x(i, 1)) = Array(x(i, 1), x(i, 2), x(i, 3))
                'End If
                Next j
            End If
        Next i
        
    'x = Application.Transpose(Application.Transpose(.Items))
    Workbooks("Книга 2.xlsx").Sheets("Лист1").Range("A1").Resize(n, 3).Value = x
'End With

End Sub

[staniiislav]

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

Такой вариант должен чуть быстрее работать:

Sub Макрос1()
  НомерСтолбцаПроверки = 1
  Application.ScreenUpdating = False
  Set R = [A1].Resize(Range("A" & Rows.Count).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column)
  [1:3].Insert Shift:=xlDown
  [4:4].Copy [A1]
  Cells(2, НомерСтолбцаПроверки) = ">0"
  R.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Intersect([1:2], R.EntireColumn), CopyToRange:=Range("Лист2!A1")
  [1:3].Delete Shift:=xlUp
  Application.ScreenUpdating = True
End Sub

я так понял копируется не вся строка, а только 1 столбец?

[DiemonStar]

я так понял копируется не вся строка, а только 1 столбец?

а что мешает попробовать и посмотреть на результат?

[staniiislav]

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

а что мешает попробовать и посмотреть на результат?

попробовал, потому и спросил