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

Вход

Регистрация

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

 

= Мир MS Excel/Макрос, зависящий от названия ячейки вписанной в шейп - Мир MS Excel

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

Excel 2019
Здравствуйте. Помогите с макросом.

В книге находятся фигуры в виде красного квадрата - название которых включает название определенных ячеек - "ФигураI27", ФигураK34 (состоит из слова "Фигура" и названия какой-то ячейки)
Эти ячейки я закрасил черным цветом.
Снизу от этой ячейки идут названия листов и названия ячеек на тех листах и числа которые нужно переместить туда.
Слева от этой черной ячейки располагается название макроса.
Справа от черной ячейки - находится единица.
Этот шаблон всегда одинаковый.

Как макросом добавить в определенные ячейки, определенных листов - числа которые стоят по левую сторону от названия ячеек, Удалить число идущее по левую сторону от ячейки (зеленая), И запустить макрос, записанный по правую сторону от ячейки (синий) ?
(То есть макросу нужно как-то ориентироваться на название ячейки, которая включена в имя шейпа и потом выполнить эти арифметические операции.)
К сообщению приложен файл: 6575.xls (48.0 Kb)
 
Ответить
СообщениеЗдравствуйте. Помогите с макросом.

В книге находятся фигуры в виде красного квадрата - название которых включает название определенных ячеек - "ФигураI27", ФигураK34 (состоит из слова "Фигура" и названия какой-то ячейки)
Эти ячейки я закрасил черным цветом.
Снизу от этой ячейки идут названия листов и названия ячеек на тех листах и числа которые нужно переместить туда.
Слева от этой черной ячейки располагается название макроса.
Справа от черной ячейки - находится единица.
Этот шаблон всегда одинаковый.

Как макросом добавить в определенные ячейки, определенных листов - числа которые стоят по левую сторону от названия ячеек, Удалить число идущее по левую сторону от ячейки (зеленая), И запустить макрос, записанный по правую сторону от ячейки (синий) ?
(То есть макросу нужно как-то ориентироваться на название ячейки, которая включена в имя шейпа и потом выполнить эти арифметические операции.)

Автор - Dalm
Дата добавления - 10.12.2023 в 08:38
Gustav Дата: Понедельник, 11.12.2023, 02:50 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2652
Репутация: 1114 ±
Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1
Держите! Модулю нужно придать нижеследующий вид, а также назначить фигурам-квадратам макросы ФигураI27_Щелчок и ФигураK34_Щелчок. В прилагаемом файле это всё уже сделано, просто тестируйте. Все макросы фигур вызывают единую подпрограмму обработки runShapeMacro, которая и "разруливает" контекст по переданному имени фигуры в Application.Caller.

[vba]
Код
Option Explicit

Sub Макрос1()
    [A27] = [A27] + 1
End Sub

Sub Макрос2()
    [A29] = [A29] + 1
End Sub

Sub ФигураI27_Щелчок()
    runShapeMacro Application.Caller
End Sub

Sub ФигураK34_Щелчок()
    runShapeMacro Application.Caller
End Sub

Sub runShapeMacro(ByVal shapeName As String)

    Dim rng         As Range
    Dim rngCurr     As Range
    Dim rngDest     As Range
    Dim wksName     As String
    Dim cellAddr    As String
    Dim addr        As String
    Dim rowLast     As Long
    Dim row         As Long
    
    addr = Replace(shapeName, "Фигура", "")
    Set rng = ActiveSheet.Range(addr)

    Set rngCurr = rng.CurrentRegion
    rowLast = rngCurr.row + rngCurr.Rows.Count - 1 - rng.row
    
    'добавить в  определенные ячейки, определенных листов -
    'числа которые стоят по левую сторону от названия ячеек,
    For row = 1 To rowLast
        wksName = rng.Offset(row, 1)
        If wksName <> "" Then
            cellAddr = rng.Offset(row, 0)
            Set rngDest = Worksheets(wksName).Range(cellAddr)
            rngDest.Value = rng.Offset(row, -1)
        End If
    Next row
    
    'Удалить число идущее по левую сторону от ячейки,
    rng.Previous.MergeArea.Cells(1) = ""
    
    'И запустить макрос, записанный по правую сторону от ячейки.
    Application.Run CStr(rng.Offset(0, 1))
End Sub
[/vba]

P.S. ВАЖНО! Каждый блок фигур должен быть отделен от остальных элементов рабочего листа пустыми ячейками по всем направлениям, т.е. должен быть "островом", со всех сторон "омываемым" пустыми ячейками. Это нужно для корректного срабатывания метода Range.CurrentRegion. Проверить текущий регион можно, встав в черную ячейку с красной кнопкой и нажав Ctrl+Shift+8 (или *).
К сообщению приложен файл: 6575_03.xls (57.0 Kb)


МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Понедельник, 11.12.2023, 03:16
 
Ответить
СообщениеДержите! Модулю нужно придать нижеследующий вид, а также назначить фигурам-квадратам макросы ФигураI27_Щелчок и ФигураK34_Щелчок. В прилагаемом файле это всё уже сделано, просто тестируйте. Все макросы фигур вызывают единую подпрограмму обработки runShapeMacro, которая и "разруливает" контекст по переданному имени фигуры в Application.Caller.

[vba]
Код
Option Explicit

Sub Макрос1()
    [A27] = [A27] + 1
End Sub

Sub Макрос2()
    [A29] = [A29] + 1
End Sub

Sub ФигураI27_Щелчок()
    runShapeMacro Application.Caller
End Sub

Sub ФигураK34_Щелчок()
    runShapeMacro Application.Caller
End Sub

Sub runShapeMacro(ByVal shapeName As String)

    Dim rng         As Range
    Dim rngCurr     As Range
    Dim rngDest     As Range
    Dim wksName     As String
    Dim cellAddr    As String
    Dim addr        As String
    Dim rowLast     As Long
    Dim row         As Long
    
    addr = Replace(shapeName, "Фигура", "")
    Set rng = ActiveSheet.Range(addr)

    Set rngCurr = rng.CurrentRegion
    rowLast = rngCurr.row + rngCurr.Rows.Count - 1 - rng.row
    
    'добавить в  определенные ячейки, определенных листов -
    'числа которые стоят по левую сторону от названия ячеек,
    For row = 1 To rowLast
        wksName = rng.Offset(row, 1)
        If wksName <> "" Then
            cellAddr = rng.Offset(row, 0)
            Set rngDest = Worksheets(wksName).Range(cellAddr)
            rngDest.Value = rng.Offset(row, -1)
        End If
    Next row
    
    'Удалить число идущее по левую сторону от ячейки,
    rng.Previous.MergeArea.Cells(1) = ""
    
    'И запустить макрос, записанный по правую сторону от ячейки.
    Application.Run CStr(rng.Offset(0, 1))
End Sub
[/vba]

P.S. ВАЖНО! Каждый блок фигур должен быть отделен от остальных элементов рабочего листа пустыми ячейками по всем направлениям, т.е. должен быть "островом", со всех сторон "омываемым" пустыми ячейками. Это нужно для корректного срабатывания метода Range.CurrentRegion. Проверить текущий регион можно, встав в черную ячейку с красной кнопкой и нажав Ctrl+Shift+8 (или *).

Автор - Gustav
Дата добавления - 11.12.2023 в 02:50
Dalm Дата: Понедельник, 11.12.2023, 06:03 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 48
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Gustav, спасибо
 
Ответить
СообщениеGustav, спасибо

Автор - Dalm
Дата добавления - 11.12.2023 в 06:03
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос, зависящий от названия ячейки вписанной в шейп (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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