Здравствуйте. Требуется из одной книги скопировать таблицу в другую книгу, только с определенными условиями, например, копироваться должны строки где первая ячейка окрашена в синий цвет. Написал такой код:
[vba]
Код
Dim x, i, lLastR, Color As Long Dim rb, rr, rr2 As Range
lLastR = Cells(Rows.Count, 1).End(xlUp).Row Set rb = Workbooks("master.xlsm").Worksheets("master") Set rr = rb.Range(rb.Cells(1, 1), rb.Cells(lLastR, 27)).Rows Workbooks.Open Filename:="F:\Desktop\Книга1.xlsx"
i = 1 For Each x In rr ' If x.Cells(i, 26).Value = 0 Then GoTo e: Color = x.Cells(i, 1).Interior.Color 'If Color <> 16777215 Then GoTo e: x.Copy Range("A" & i) Range("B" & i).Interior.Color = Color e: i = i + 1 Next x
[/vba] Но происходит какое то смещение. По идее ячейка B должна быть такого же цвета как и A, но B почему то окрашивается в цвет следующей ячейки A. Видимо по этой же причине и неправильно работают закомментированные условия.
Здравствуйте. Требуется из одной книги скопировать таблицу в другую книгу, только с определенными условиями, например, копироваться должны строки где первая ячейка окрашена в синий цвет. Написал такой код:
[vba]
Код
Dim x, i, lLastR, Color As Long Dim rb, rr, rr2 As Range
lLastR = Cells(Rows.Count, 1).End(xlUp).Row Set rb = Workbooks("master.xlsm").Worksheets("master") Set rr = rb.Range(rb.Cells(1, 1), rb.Cells(lLastR, 27)).Rows Workbooks.Open Filename:="F:\Desktop\Книга1.xlsx"
i = 1 For Each x In rr ' If x.Cells(i, 26).Value = 0 Then GoTo e: Color = x.Cells(i, 1).Interior.Color 'If Color <> 16777215 Then GoTo e: x.Copy Range("A" & i) Range("B" & i).Interior.Color = Color e: i = i + 1 Next x
[/vba] Но происходит какое то смещение. По идее ячейка B должна быть такого же цвета как и A, но B почему то окрашивается в цвет следующей ячейки A. Видимо по этой же причине и неправильно работают закомментированные условия.sdr
Public Sub test() Dim rng1 As Range Dim i As Integer, j%
Set rng1 = Worksheets("master").Range("A1:AA27")
j = 0 For i = 1 To rng1.Rows.Count If rng1.Cells(i, 1).Interior.Color = rng1.Cells(3, 1).Interior.Color Then j = j + 1 Worksheets("out").Cells(j, 1) = rng1.Cells(i, 1) & i End If Next i End Sub
[/vba]
ну вот основа для перебора [vba]
Код
Public Sub test() Dim rng1 As Range Dim i As Integer, j%
Set rng1 = Worksheets("master").Range("A1:AA27")
j = 0 For i = 1 To rng1.Rows.Count If rng1.Cells(i, 1).Interior.Color = rng1.Cells(3, 1).Interior.Color Then j = j + 1 Worksheets("out").Cells(j, 1) = rng1.Cells(i, 1) & i End If Next i End Sub
Color2 = rr.Cells(3, 1).Interior.Color For i = 1 To lLastR Color = rr.Cells(i, 1).Interior.Color If Color <> Color2 Then GoTo e: 'If rr.Cells(i, 26).Value = 0 Then GoTo e: rr.Range(rr.Cells(i, 1), rr.Cells(i, 27)).Copy Range("A" & i) e: Next i
[/vba] Заработало. В связи с этим возникли вопросы: 1. Почему первый вариант кода не работал? По сути всё также 2. Почему такая конструкция НЕ работает Color <> 16777215, а такая Color <> Color2 работает? 3. Как сделать пропуск пустых строк? Закомментированное условие не дает результата.
Сделал так [vba]
Код
Color2 = rr.Cells(3, 1).Interior.Color For i = 1 To lLastR Color = rr.Cells(i, 1).Interior.Color If Color <> Color2 Then GoTo e: 'If rr.Cells(i, 26).Value = 0 Then GoTo e: rr.Range(rr.Cells(i, 1), rr.Cells(i, 27)).Copy Range("A" & i) e: Next i
[/vba] Заработало. В связи с этим возникли вопросы: 1. Почему первый вариант кода не работал? По сути всё также 2. Почему такая конструкция НЕ работает Color <> 16777215, а такая Color <> Color2 работает? 3. Как сделать пропуск пустых строк? Закомментированное условие не дает результата.sdr
Если Вы по 26 столбцу проверяете, можно попробовать [vba]
Код
Public Sub test() Dim rng1 As Range Dim i As Integer, j%
Set rng1 = Worksheets("master").Range("A1:AA27")
j = 0 For i = 1 To rng1.Rows.Count If rng1.Cells(i, 1).Interior.Color = rng1.Cells(3, 1).Interior.Color Then If rng1.Cells(i, 26).Text <> "" Then j = j + 1 Worksheets("out").Cells(j, 1) = rng1.Cells(i, 1) & i End If End If Next i End Sub
Если Вы по 26 столбцу проверяете, можно попробовать [vba]
Код
Public Sub test() Dim rng1 As Range Dim i As Integer, j%
Set rng1 = Worksheets("master").Range("A1:AA27")
j = 0 For i = 1 To rng1.Rows.Count If rng1.Cells(i, 1).Interior.Color = rng1.Cells(3, 1).Interior.Color Then If rng1.Cells(i, 26).Text <> "" Then j = j + 1 Worksheets("out").Cells(j, 1) = rng1.Cells(i, 1) & i End If End If Next i End Sub