Всем форумчанам и знатокам Экселя, привет! Нужен макрос-скрипт. В таблице есть столбцы №1 и №2. И в них появляются числа от 0 до 2. Требуется перенести строку, если в одном из столбцов появилось число 2. Перенос нужен сделать в лист соответствующий нумерации столбца ( №1 или №2). Там уже есть готовая таблица под приём новых строк статы. Кнопку я заранее сделал, под прикрепление Макрос-скрипта.
P.S. Желательно обойтись без фильтрации в этих столбцах и дальнейшего КопиПаста..
Всем форумчанам и знатокам Экселя, привет! Нужен макрос-скрипт. В таблице есть столбцы №1 и №2. И в них появляются числа от 0 до 2. Требуется перенести строку, если в одном из столбцов появилось число 2. Перенос нужен сделать в лист соответствующий нумерации столбца ( №1 или №2). Там уже есть готовая таблица под приём новых строк статы. Кнопку я заранее сделал, под прикрепление Макрос-скрипта.
P.S. Желательно обойтись без фильтрации в этих столбцах и дальнейшего КопиПаста..Andrius
Sub copyData() Dim sh As Worksheet Dim lr1&, lr2& lr1 = Cells(Rows.Count, 1).End(xlUp).Row 'Если старые данные стирать не нужно, то убрать следующий 2 строчки ThisWorkbook.Sheets("№1").Cells(1, 1).CurrentRegion.Offset(1).ClearContents ThisWorkbook.Sheets("№2").Cells(1, 1).CurrentRegion.Offset(1).ClearContents For i = 2 To lr1 If Cells(i, 1) = 2 Then Set sh = ThisWorkbook.Sheets("№1") ElseIf Cells(i, 2) = 2 Then Set sh = ThisWorkbook.Sheets("№2") End If If Not sh Is Nothing Then With sh lr2 = .Cells(Rows.Count, 1).End(xlUp).Row + 1 .Cells(lr2, 1).Resize(, 7).Value = Cells(i, 3).Resize(, 7).Value End With End If Set sh = Nothing Next i End Sub
[/vba]
Andrius, здравствуйте, так подойдет? [vba]
Код
Sub copyData() Dim sh As Worksheet Dim lr1&, lr2& lr1 = Cells(Rows.Count, 1).End(xlUp).Row 'Если старые данные стирать не нужно, то убрать следующий 2 строчки ThisWorkbook.Sheets("№1").Cells(1, 1).CurrentRegion.Offset(1).ClearContents ThisWorkbook.Sheets("№2").Cells(1, 1).CurrentRegion.Offset(1).ClearContents For i = 2 To lr1 If Cells(i, 1) = 2 Then Set sh = ThisWorkbook.Sheets("№1") ElseIf Cells(i, 2) = 2 Then Set sh = ThisWorkbook.Sheets("№2") End If If Not sh Is Nothing Then With sh lr2 = .Cells(Rows.Count, 1).End(xlUp).Row + 1 .Cells(lr2, 1).Resize(, 7).Value = Cells(i, 3).Resize(, 7).Value End With End If Set sh = Nothing Next i End Sub