Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Некорректная работа цикла по копированию строк - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Некорректная работа цикла по копированию строк (Макросы/Sub)
Некорректная работа цикла по копированию строк
sdr Дата: Воскресенье, 07.02.2016, 13:50 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Здравствуйте. Требуется из одной книги скопировать таблицу в другую книгу, только с определенными условиями, например, копироваться должны строки где первая ячейка окрашена в синий цвет. Написал такой код:

[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. Видимо по этой же причине и неправильно работают закомментированные условия.
К сообщению приложен файл: master.xlsm (63.7 Kb)


Сообщение отредактировал sdr - Воскресенье, 07.02.2016, 14:12
 
Ответить
СообщениеЗдравствуйте. Требуется из одной книги скопировать таблицу в другую книгу, только с определенными условиями, например, копироваться должны строки где первая ячейка окрашена в синий цвет. Написал такой код:

[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
Дата добавления - 07.02.2016 в 13:50
sdr Дата: Воскресенье, 07.02.2016, 14:28 | Сообщение № 2
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Уже давно исправил
 
Ответить
СообщениеУже давно исправил
Автор - sdr
Дата добавления - 07.02.2016 в 14:28
Udik Дата: Воскресенье, 07.02.2016, 14:39 | Сообщение № 3
Группа: Друзья
Ранг: Старожил
Сообщений: 1588
Репутация: 192 ±
Замечаний: 0% ±

Excel 2016 х 64
ну вот основа для перебора
[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

[/vba]
К сообщению приложен файл: 1773966.xlsm (64.8 Kb)

вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com
 
Ответить
Сообщениену вот основа для перебора
[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

[/vba]
Автор - Udik
Дата добавления - 07.02.2016 в 14:39
sdr Дата: Воскресенье, 07.02.2016, 16:29 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Сделал так
[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. Как сделать пропуск пустых строк? Закомментированное условие не дает результата.
 
Ответить
СообщениеСделал так
[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
Дата добавления - 07.02.2016 в 16:29
Udik Дата: Воскресенье, 07.02.2016, 17:03 | Сообщение № 5
Группа: Друзья
Ранг: Старожил
Сообщений: 1588
Репутация: 192 ±
Замечаний: 0% ±

Excel 2016 х 64
Цитата sdr, 07.02.2016 в 16:29, в сообщении № 4
НЕ работает Color <> 16777215, а такая Color <> Color2 работает

ну Color2 = 16764057, а не 16777215, т.е. выражения не одинаковые как минимум (поэтому лучше из образца цвет брать, а не константой писать :) ).

Цитата sdr, 07.02.2016 в 16:29, в сообщении № 4
Как сделать пропуск пустых строк

Если Вы по 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
[/vba]
К сообщению приложен файл: 2423543.xlsm (65.1 Kb)

вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com

Сообщение отредактировал Udik - Воскресенье, 07.02.2016, 17:07
 
Ответить
Сообщение
Цитата sdr, 07.02.2016 в 16:29, в сообщении № 4
НЕ работает Color <> 16777215, а такая Color <> Color2 работает

ну Color2 = 16764057, а не 16777215, т.е. выражения не одинаковые как минимум (поэтому лучше из образца цвет брать, а не константой писать :) ).

Цитата sdr, 07.02.2016 в 16:29, в сообщении № 4
Как сделать пропуск пустых строк

Если Вы по 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
[/vba]
Автор - Udik
Дата добавления - 07.02.2016 в 17:03
sdr Дата: Понедельник, 08.02.2016, 09:44 | Сообщение № 6
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Спасибо. То, что надо. Работает!!!!
 
Ответить
СообщениеСпасибо. То, что надо. Работает!!!!
Автор - sdr
Дата добавления - 08.02.2016 в 09:44
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Некорректная работа цикла по копированию строк (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!