Страницы: 1
RSS
Перенести заливку из диапазона одного размера в диапазон другого размера
 
Доброй ночи!Помогите, пожалуйста перенести заливку в приложенном файле из вкладки "1" на вкладку "Кандалакша". Условие такое, если дом из вкладки "1" содержится во вкладке "Кандалакша", то ячейки в графах январь 2017 - декабрь 2017 должны приобрести такую же заливку как и аналогичные ячейки во вкладке "1".
 
maria_gug, Доброе утро!
Зачем на вкладке Кандалакша два столбца с Корпус
Цитата
из диапазона одного размера в диапазон другого размера
Размер вроде одинаковый - 12 ячеек
На вкладке 1 адрес в виде "50 Лет Октября@8@0" Это так мой конвертер преобразовал?
Или адрес действительно в таком виде? Это улица 50 Лет Октября, дом 8, корпус 0
 
Цитата
Kuzmich написал:
Это так мой конвертер преобразовал?
нет, у меня также, и что делать надо - непонятно  :cry:
Соблюдение правил форума не освобождает от модераторского произвола
 
Добрый день! Так?
 
Андрей_26, из цикла можно проще выходить:
Скрытый текст
Соблюдение правил форума не освобождает от модераторского произвола
 
buchlotnik я в курсе ))) но мне так больше нравится
 
Цитата
Андрей_26 написал: Так?
Добрый день!
Да, это то, что было нужно. Спасибо!
 
Цитата
перенести заливку
Не используя столбец I (ID) на вкладке Кандалакша
Код
'запускать при активном листе 1
Sub Zalivka()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim FAdr As String
Application.ScreenUpdating = False
 With Worksheets("Кандалакша")
   iLastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
   .Range("K4:V" & iLastRow).Interior.ColorIndex = xlNone
     iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = 1 To iLastRow
    Set FoundCell = .Columns(4).Find(Split(Cells(i, "A"), "@")(0), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      Do
        If CStr(FoundCell.Offset(, 1)) = Split(Cells(i, "A"), "@")(1) And _
           CStr(FoundCell.Offset(, 3)) = Split(Cells(i, "A"), "@")(2) Then
           Range("B" & i & ":M" & i).Copy
           FoundCell.Offset(, 7).PasteSpecial xlPasteFormats
        End If
       Set FoundCell = .Columns(4).FindNext(FoundCell)
      Loop While FoundCell.Address <> FAdr
     End If
  Next
 End With
Application.ScreenUpdating = True
End Sub
Страницы: 1
Наверх