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

Вход

Регистрация

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

 

= Мир MS Excel/Ссылка в макросе на другой лист - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Ссылка в макросе на другой лист
MrHell Дата: Четверг, 18.08.2022, 17:31 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Добрый день.
в VBA не силен, поэтому обращаюсь к вам.
У меня есть макрос который делает фигуру прозрачной по значению в ячейке.
Мне необходимо чтоб название фигуры и значение находились на другом листе,
ну допустим Лист2 ячейка F10.
Соответственно в макросе должна быть ссылка на конкретный лист и ячейку.
К сожалению сделать самому не получилось подскажите вы пожалуйста.
Пример кода.
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
lr = Cells(Rows.Count, 2).End(xlUp).Row
arr = Range(Cells(10, 1), Cells(lr, 3)).Value
For Each Shape In ActiveSheet.Shapes
    For i = 1 To UBound(arr)
         If Shape.Name = arr(i, 1) Then
            If arr(i, 2) = 1 Then Shape.Fill.Transparency = 1
            If arr(i, 2) = 2 Then Shape.Fill.Transparency = 0
         End If
    Next
Next
End Sub
[/vba]
К сообщению приложен файл: _1.xls (43.0 Kb)
 
Ответить
Сообщение
Добрый день.
в VBA не силен, поэтому обращаюсь к вам.
У меня есть макрос который делает фигуру прозрачной по значению в ячейке.
Мне необходимо чтоб название фигуры и значение находились на другом листе,
ну допустим Лист2 ячейка F10.
Соответственно в макросе должна быть ссылка на конкретный лист и ячейку.
К сожалению сделать самому не получилось подскажите вы пожалуйста.
Пример кода.
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
lr = Cells(Rows.Count, 2).End(xlUp).Row
arr = Range(Cells(10, 1), Cells(lr, 3)).Value
For Each Shape In ActiveSheet.Shapes
    For i = 1 To UBound(arr)
         If Shape.Name = arr(i, 1) Then
            If arr(i, 2) = 1 Then Shape.Fill.Transparency = 1
            If arr(i, 2) = 2 Then Shape.Fill.Transparency = 0
         End If
    Next
Next
End Sub
[/vba]

Автор - MrHell
Дата добавления - 18.08.2022 в 17:31
Sancho Дата: Пятница, 19.08.2022, 07:31 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 279
Репутация: 19 ±
Замечаний: 0% ±

2007, 2010, 2013
MrHell, добрый день!
Если правильно я понял то по всей видимости так:
[vba]
Код

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
lr = Cells(Rows.Count, 2).End(xlUp).Row
With Sheets("Лист2") 'sancho
    arr = .Range(.Cells(1, 1), .Cells(lr, 3)).Value 'sancho
End With 'sancho
For Each Shape In ActiveSheet.Shapes
    For i = 1 To UBound(arr)
         If Shape.Name = arr(i, 1) Then
            If arr(i, 2) = 1 Then Shape.Fill.Transparency = 1
            If arr(i, 2) = 2 Then Shape.Fill.Transparency = 0
         End If
    Next
Next
End Sub

[/vba]
PS: добавленные, отредактированные строки отмечены комментарием 'sancho
К сообщению приложен файл: _1-sancho.xls (44.5 Kb)


Сообщение отредактировал Sancho - Пятница, 19.08.2022, 07:32
 
Ответить
СообщениеMrHell, добрый день!
Если правильно я понял то по всей видимости так:
[vba]
Код

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
lr = Cells(Rows.Count, 2).End(xlUp).Row
With Sheets("Лист2") 'sancho
    arr = .Range(.Cells(1, 1), .Cells(lr, 3)).Value 'sancho
End With 'sancho
For Each Shape In ActiveSheet.Shapes
    For i = 1 To UBound(arr)
         If Shape.Name = arr(i, 1) Then
            If arr(i, 2) = 1 Then Shape.Fill.Transparency = 1
            If arr(i, 2) = 2 Then Shape.Fill.Transparency = 0
         End If
    Next
Next
End Sub

[/vba]
PS: добавленные, отредактированные строки отмечены комментарием 'sancho

Автор - Sancho
Дата добавления - 19.08.2022 в 07:31
MrHell Дата: Пятница, 19.08.2022, 16:45 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Sancho,
Огромнейшее вам спасибо все работает как надо.
 
Ответить
СообщениеSancho,
Огромнейшее вам спасибо все работает как надо.

Автор - MrHell
Дата добавления - 19.08.2022 в 16:45
  • Страница 1 из 1
  • 1
Поиск:

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