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
Вопрос: как бы сделать так, чтобы этот логотип постепенно заменялся бы на другой рисунок (он хранится рядом с логотипом, на том же листе). Постепенно – это значит по одной клеточке в случайном порядке, как иногда меняют кадры в фильмах.
То есть все клеточки логотипа по очереди заменяются на клеточки другого рисунка, но не построчно, а в случайном порядке (примерно так же, как на аватаре АДМИНА)
Спасибо.
|
Всего сообщений: 2 | Присоединился: май 2008 | Отправлено: 23 мая 2008 9:29 | IP
|
|
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
ThisWorkbook.Sheets(2).Range("A1:CV100").ClearContents
k = 0
For i = 1 To 100
For j = 1 To 100
If Sheets(2).Cells(i, j).Interior.ColorIndex <> Sheets(1).Cells(i, j).Interior.ColorIndex Then
k = k + 1
Sheets(2).Cells(i, j).Value = k
' l.Add k, CStr(k)
End If
Next
Next
For i = 1 To 100
For j = 1 To 100
If Sheets(2).Cells(i, j).Value > 0 Then
Metka: a = Int(Rnd() * k + 1)
On Error Resume Next
x.Add a, CStr(a)
If Err <> 0 Then
On Error GoTo 0
GoTo Metka
End If
.Cells(i, j) = a
End If
Next
Next
Set x = Nothing
For a = 1 To k
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
|
Всего сообщений: 2 | Присоединился: май 2008 | Отправлено: 2 июня 2008 17:23 | IP
|
|
marnich
Новичок
|
Включить индивидуальный счётчик доверия к убивающим во имя лучшей жизни. И исполнить последнюю волю невинно лишаемых этой жизни.
---------------------------------------------------------------------------------
Чтобы любой человек мог с помощью этого послания оформить свой личный оригинальный вклад в мировое культурное наследие, в текст введены двумя именами собственными обозначения ангелов для исполнения роли посредников между причастными к убийствам взрослыми и убитыми детьми – Хавзан и Тотаси.
С помощью этой пары слов каждый, кто в этом нуждается, может зашифровать нужные ему сведения, чтобы использовать их впоследствии для подтверждения обоснованности своих претензий на признание конкретных заслуг, включая анонимную деятельность в сети Интернет. В других местах исходного текста использование тайнописи не предусмотрено и всё написанное следует воспринимать буквально.
С сегодняшнего дня весь оставшийся у меня запас доверия к еврейской нации я принимаю за 100% против таких же 100% сохранившегося остатка доверия к участникам палестинского вооружённого сопротивления. А начиная с 9 февраля 2009 года из обоих сумм начинаю вычитать по 1% за каждый долетевший до израильской территории снаряд и за каждого убитого израильтянами палестинца. Данные для изменения показаний счётчика берём из официальных сообщений по таким каналам, как Евроньюс.
Каждый поступающий аналогично должен хорошо осознавать, что реакция любой из участвующих в ближневосточном конфликте сторон на очередной включённый счётчик определяется скоростью возрастания количества людей, которые открыто поддерживают инициативу по включению индивидуальных счётчиков доверия, распространяя дальше этот призыв.
Для информирования общества о своей инициативе такой человек публикует повторно исходный текст, изменяя лишь дату и обозначение лица, которому он хочет посвятить от своего имени всё, чего мы сможем добиться сообща к указанному времени. Например, если показанный к 09.02.09г. результат будет стоить того, то пусть особо за нас порадуются все Галины, которые в этот день родились. Кто не считает нужным делать такие посвящения, тот исключает этот абзац из своего текста.
Пока не найден лучший способ оценки количества людей, включивших индивидуальные счётчики оставшегося доверия, все желающие быть учтёнными в этом качестве отмечаются в блоге сообщества «Но есть одно НО», с которого начинается, как с чистого листа, совершенно новая, ироническая и сугубо позитивная история слова «жид». внешняя ссылка удалена
Чтобы отметиться в порядке саморегистрации, можно просто отдать свой голос по варианту опроса, опубликованного на первой странице блога. Но можно оставить ещё и комментарий по факту включения индивидуального счётчика. Здесь же опубликован текст молитвы двух маленьких курдов, которая непосредственно предшествовала возникновению идеи включить счётчик.
При повторном опубликовании текста желающие могут добавлять свои имена и прочие реквизиты, пока список невелик, учёт не продуман и сама идея не опробована. А потом появятся обратные связи, которые и приведут весь порядок продвижения идеи в надлежащий вид.
Михаил С. /МАРНИЧ/
02.02.09г. г. Минск
|
Всего сообщений: 15 | Присоединился: сентябрь 2007 | Отправлено: 5 фев. 2009 3:55 | IP
|
|
kes2006
Новичок
|
помогите пожалуйста составили програмку в VBA, но почему то она не считает y при предельном значении x. условие расчитать y при x от -3 до 1,8 с шагом 0,6. вот что мы сотворилиPublic Sub zadacha1()
Dim a, b, x0, xk, dx, x, y As Single
Cells(1, 1).Value = "a"
Cells(1, 2).Value = "b"
Cells(1, 3).Value = "x0"
Cells(1, 4).Value = "xk"
Cells(1, 5).Value = "dx"
a = Cells(2, 1).Value
b = Cells(2, 2).Value
x0 = Cells(2, 3).Value
xk = Cells(2, 4).Value
dx = Cells(2, 5).Value
x = x0
i = 4
10 If x > 0 Then
y = Sqr(b ^ 3) / x + Sin(a * x / 9)
Else
y = Sqr(b ^ 3) / x + Sin(a * x / 9)
End If
Cells(4, 1).Value = "x"
Cells(4, 2).Value = "y"
Cells(i + 1, 1).Value = x
Cells(i + 1, 2).Value = y
If x <> 0 Then
End If
Cells(10, 2).Value = "otvet net"
i = i + 1
x = x + dx
If x <= xk Then GoTo 10
End Sub
|
Всего сообщений: 14 | Присоединился: февраль 2009 | Отправлено: 7 марта 2009 19:14 | IP
|
|
|
Форум
Как поменять картинку на VBA Excel
