Как поменять картинку (анимация на листе)

[dsapa]

Здравствуйте!
Я создал такой макрос – увеличение логотипа при открытии файла (логотип представляет собой эмблему из разукрашенных клеток):

Sheets("Анимация").Select
Range("A1").Select
Dim Data0 As Range
Set Data0 = Cells(1, 1)
Dim Data2 As Range
Set Data2 = Cells(2631, 1)
'Очистка поля
Data2.Resize(288, 256).Copy Destination:=Data0.Resize(288, 256)
'начальная установка масштаба
ActiveWindow.Zoom = 10
Data2.Resize(288, 256).Copy Destination:=Data0.Resize(288, 256)
'Нахождение координат и вставка базового логотипа
Data0.Cells(837, 193).Resize(33, 52).Copy Destination:= _
Cells(1, 1).Resize(33, 52)
Sleep 500
'выбор начальной ячейки
Cells(1, 1).Select
'увеличение логотипа
For i = 10 To 400 Step 1
ActiveWindow.Zoom = i
Next i
ActiveWindow.Zoom = 400
Cells(873, 193).Resize(33, 52).Copy Destination:= _
Cells(1, 1).Resize(33, 52)
Sleep 2000
'Очистка поля
Data2.Resize(288, 256).Copy Destination:=Data0.Resize(288, 256)
ActiveWindow.Zoom = 10
Sleep 10
Worksheets("Отчет").Select
Range("A1").Select

Вопрос: как бы сделать так, чтобы этот логотип постепенно заменялся бы на другой рисунок (он хранится рядом с логотипом, на том же листе). Постепенно – это значит по одной клеточке в случайном порядке, как иногда меняют кадры в фильмах.
То есть все клеточки логотипа по очереди заменяются на клеточки другого рисунка, но не построчно, а в случайном порядке.
Спасибо.

[SAS888]

Посмотрите один из возможных вариантов.

[dsapa]

Спасибо! Это то, что надо. Правда работает без ошибок только если весь рисунок - сплошной одноцветный фон. При разных цветах клеток макрос зависает и приходится принудительно его останавливать через дебуггер. Ну ничего, я разберусь. Спасибо!

[SAS888]

У меня, для простоты, контролируется, что весь диапазон имеет тот же цвет, что одна из ячеек соседнего. Придумайте свое условие выхода из процедуры.

[dsapa]

Я устроил сравнение цвета каждой ячейки через "For - Next" по столбцам и строчкам. Вот что получилось:
Sub qq()

Dim r As Integer, c As Integer
Metka: r = Int(Rnd() * 10 + 1)
c = Int(Rnd() * 10 + 1)
If Cells(r, c).Interior.ColorIndex = Cells(r, c).Offset(, 15).Interior.ColorIndex Then GoTo Metka
Cells(r, c).Interior.ColorIndex = Cells(r, c).Offset(, 15).Interior.ColorIndex
Sleep 30
For r = 1 To 10
For c = 1 To 10
If Cells(r, c).Interior.ColorIndex <> Cells(r, c).Offset(, 15).Interior.ColorIndex Then GoTo Metka
Next
Next

End Sub

На 100 клетках работает быстро, попробую картинку 256х256.

[dsapa]

Заметил: макрос виснет, если обе картинки идентичны.

[dsapa]

На большом числе клеток в конце работы макрос тормозит. Это потому, что он каждый раз в цикле проверяет абсолютно все клетки. Как бы сделать так, чтобы клетки, изменившие свой цвет, больше не проверялсь?

[SAS888]

Посмотрите следующее вложение.
Здесь на листе 2 в диапазоне 100 на 100 клеток (от "A1") расположена область картинки. Работа макроса состоит из двух частей. Сначала, исходный диапазон заполняется значениями от 1 до 10000 в случайном порядке. Затем происходит поиск этих значений (уже по порядку) и "перекрашивание" картинки. Тормозов при "перекрашивании" нет, но в начале (при заполнении значениями) происходит незначительная задержка. В принципе, если не нужно каждый раз менять порядок "перекрашивания", то можно оставить заполненный значениями исходный диапазон, сохранить файл, а первую часть макроса "START" исключить.
P.S. макрос работает с адресами ячеек, поэтому критерий выхода из цикла (процедуры) не нужен.

[dsapa]

Замечательно! Спасибо за подсказку. С Вашим кодом разобрался.
Теперь думаю вот над чем:
Даже если в обоих рисунках разнятся всего лишь пара клеток, макрос отрабатывает полностью все клетки, даже идентичные. Щас попробую ввести в код строчку, которая сравнивала бы цвет клеток при заполнении в случайном порядке и сразу бы не брала их в расчет при дальнейшем закрашивании. Тогде при малом количестве разнящихся клеток, макрос будет отрабатывать только эти разнящиеся клетки, соответственно, сократится время работы макроса.

[dsapa]

Sub Start()

Dim i As Integer, j As Integer, a As Long, x As New Collection, y As Range
With Sheets(2)
.Range(.Cells(1, 1), .Cells(100, 100)).ClearContents
For i = 1 To 100
For j = 1 To 100
Metka: a = Int(Rnd() * 10000 + 1)
On Error Resume Next
If Sheets(2).Cells(i, j).Interior.ColorIndex <> Sheets(1).Cells(i, j).Interior.ColorIndex Then
x.Add a, CStr(a)
If Err <> 0 Then
On Error GoTo 0
GoTo Metka
End If
.Cells(i, j) = a
Else:
End If
Next
Next
Set x = Nothing
For a = 1 To 10000
Set y = .Range(.Cells(1, 1), .Cells(100, 100)).Find(What:=a, LookAt:=xlWhole)
If Not y Is Nothing Then Sheets(1).Cells(y.Row, y.Column).Interior.ColorIndex = y.Interior.ColorIndex
Next
End With
End Sub
Работа макроса ускоряется, но ненамного, потому что если разнятся только, допустим, четыре клетки, макрос помечает их в порядке очередности работы генератора случайных чисел. А надо, чтобы он их помечал в первую очередь, и только их (но тоже в случайном порядке).