Sub test() With Application: .ScreenUpdating = 0: .EnableEvents = 0 With Me.UsedRange .AutoFilter Field:=5, Criteria1:="1" .Copy: Me.Next.[A1].PasteSpecial 8, xlNone, False, False .Copy Me.Next.[A1] .AutoFilter End With .ScreenUpdating = 1: .EnableEvents = 1: End With End Sub
[/vba]
можно так [vba]
Код
Sub test() With Application: .ScreenUpdating = 0: .EnableEvents = 0 With Me.UsedRange .AutoFilter Field:=5, Criteria1:="1" .Copy: Me.Next.[A1].PasteSpecial 8, xlNone, False, False .Copy Me.Next.[A1] .AutoFilter End With .ScreenUpdating = 1: .EnableEvents = 1: End With End Sub
Sub test() Dim z(), i&, j&, m&: z = Range("E1:E" & Range("E" & Rows.Count).End(xlUp).Row).Value For i = 1 To UBound(z) If z(i, 1) = "1" Then m = m + 1: For j = 1 To UBound(z, 2): z(m, j) = z(i, j): Next End If Next Sheets("Лист1").Range("A1").Resize(m, UBound(z, 2)).Value = z End Sub
[/vba]
den45444, добрый день,еще вариант,кнопка test
[vba]
Код
Sub test() Dim z(), i&, j&, m&: z = Range("E1:E" & Range("E" & Rows.Count).End(xlUp).Row).Value For i = 1 To UBound(z) If z(i, 1) = "1" Then m = m + 1: For j = 1 To UBound(z, 2): z(m, j) = z(i, j): Next End If Next Sheets("Лист1").Range("A1").Resize(m, UBound(z, 2)).Value = z End Sub
sv2014, ваш вариант не подходит, потому что нужно перенести не значения столбца Е, а по этому столбцу выбрать все строки со значением "1" и перенести на другой лист со сдвигом всех строк вниз.
sv2014, ваш вариант не подходит, потому что нужно перенести не значения столбца Е, а по этому столбцу выбрать все строки со значением "1" и перенести на другой лист со сдвигом всех строк вниз.den45444
Sub test() Dim z(), z1(), iEnd%, iKol%, i%, j%, m% Const iStart% = 3 'строка начала таблицы на листе "тест" Const iColumnStart% = 1 'крайний левый столбец таблицы для копирования данных Const iColumnEnd% = 9 'крайний правый столбец таблицы для копирования данных Const iColumnInd% = 5 '№ столбца, в котором ищем критерий Const sInd As String = "1" 'критерий отбора Const iColumnPaste% = 1 'столбец левой верхней ячейки для вставки результата Const iRowPaste% = 1 'строка левой верхней ячейки для вставки результата
iEnd = Cells(Rows.Count, iColumnInd).End(xlUp).Row 'последняя заполненная строка в столбце,где критерии отбора z = Range(Cells(iStart, iColumnStart), Cells(iEnd, iColumnEnd)).Value 'массив таблицы с листа "тест" iKol = WorksheetFunction.CountIf(Range(Cells(iStart, iColumnInd), Cells(iEnd, iColumnInd)), sInd) 'количество всего найденных критериев в таблице ReDim z1(1 To iKol, 1 To UBound(z, 2))
For i = 1 To UBound(z, 1) If z(i, iColumnInd) = sInd Then m = m + 1: For j = 1 To UBound(z, 2): z1(m, j) = z(i, j): Next End If Next
With Sheets("Лист1") 'Вставляем на лист с именем Лист1 .Range(.Cells(iRowPaste, iColumnPaste), .Cells(UBound(z1, 1) + iRowPaste - 1, UBound(z1, 2) + iColumnPaste - 1)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove .Cells(iRowPaste, iColumnPaste).Resize(m, UBound(z, 2)).Value = z1 End With End Sub
[/vba]
[p.s.]Пока ходил уже "Вопрос решен..." (((((
мой пример
[vba]
Код
Sub test() Dim z(), z1(), iEnd%, iKol%, i%, j%, m% Const iStart% = 3 'строка начала таблицы на листе "тест" Const iColumnStart% = 1 'крайний левый столбец таблицы для копирования данных Const iColumnEnd% = 9 'крайний правый столбец таблицы для копирования данных Const iColumnInd% = 5 '№ столбца, в котором ищем критерий Const sInd As String = "1" 'критерий отбора Const iColumnPaste% = 1 'столбец левой верхней ячейки для вставки результата Const iRowPaste% = 1 'строка левой верхней ячейки для вставки результата
iEnd = Cells(Rows.Count, iColumnInd).End(xlUp).Row 'последняя заполненная строка в столбце,где критерии отбора z = Range(Cells(iStart, iColumnStart), Cells(iEnd, iColumnEnd)).Value 'массив таблицы с листа "тест" iKol = WorksheetFunction.CountIf(Range(Cells(iStart, iColumnInd), Cells(iEnd, iColumnInd)), sInd) 'количество всего найденных критериев в таблице ReDim z1(1 To iKol, 1 To UBound(z, 2))
For i = 1 To UBound(z, 1) If z(i, iColumnInd) = sInd Then m = m + 1: For j = 1 To UBound(z, 2): z1(m, j) = z(i, j): Next End If Next
With Sheets("Лист1") 'Вставляем на лист с именем Лист1 .Range(.Cells(iRowPaste, iColumnPaste), .Cells(UBound(z1, 1) + iRowPaste - 1, UBound(z1, 2) + iColumnPaste - 1)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove .Cells(iRowPaste, iColumnPaste).Resize(m, UBound(z, 2)).Value = z1 End With End Sub
[/vba]
[p.s.]Пока ходил уже "Вопрос решен..." (((((devilkurs