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

Вход

Регистрация

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

 

= Мир MS Excel/Группировка объектов записанных в таблицу по тексту строки - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Группировка объектов записанных в таблицу по тексту строки (Макросы/Sub)
Группировка объектов записанных в таблицу по тексту строки
ВасилисаЛукьянчикова Дата: Вторник, 30.10.2018, 04:29 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 36
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Всем доброго вечера. Помогите решить задачу.

Есть в книге экселя - выписанные в таблицу координаты объектов.
При щелчке на кнопку - имеющийся макрос размещает объекты в нужных координатах.

В строке 8 - есть отметка типа "1_1", "2_1" или "4_5" и т.д.
Эта отметка означает, что те объекты, которые имеют похожие отметки - будут объединены в группы с названиями "Группа 1_1", "Группа 4_5" и т.д. Если в этой ячейке пусто или нет другой аналогичной отметки - то группировка для этого объекта не выполняется.

Как макросом сгруппировать объекты по значению в строке 8 ?
К сообщению приложен файл: 9323931.xls(41.0 Kb)
 
Ответить
СообщениеВсем доброго вечера. Помогите решить задачу.

Есть в книге экселя - выписанные в таблицу координаты объектов.
При щелчке на кнопку - имеющийся макрос размещает объекты в нужных координатах.

В строке 8 - есть отметка типа "1_1", "2_1" или "4_5" и т.д.
Эта отметка означает, что те объекты, которые имеют похожие отметки - будут объединены в группы с названиями "Группа 1_1", "Группа 4_5" и т.д. Если в этой ячейке пусто или нет другой аналогичной отметки - то группировка для этого объекта не выполняется.

Как макросом сгруппировать объекты по значению в строке 8 ?

Автор - ВасилисаЛукьянчикова
Дата добавления - 30.10.2018 в 04:29
Roman777 Дата: Вторник, 30.10.2018, 11:11 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 888
Репутация: 115 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
ВасилисаЛукьянчикова,
[vba]
Код
Sub Макрос1()
Dim key$, o2
Dim lastcol
Dim c_x1y1, c_x2y2, Color1, Group
Dim shp

Dim shpNames() As String, shpsArr() 'массив массивов (двумерный), хранилище всех шейпов (имён)
Dim k&, n&

lastcol = Cells(2, Columns.Count).End(xlToLeft).Column

c_x1y1 = Range(Cells(2, 2), Cells(3, lastcol))
c_x2y2 = Range(Cells(5, 2), Cells(6, lastcol))
Color1 = Range(Cells(7, 2), Cells(7, lastcol))
Group = Range(Cells(8, 2), Cells(8, lastcol))

Set o2 = CreateObject("Scripting.Dictionary") ' будет флагом о том, встречали ли мы такую группу или нет

ReDim shpsArr(1 To 2, 1 To 1)
For i = 1 To lastcol - 1
    
Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, c_x1y1(1, i), c_x1y1(2, i), c_x2y2(1, i), c_x2y2(2, i)) '.Select
    With shp.Fill
        .Visible = msoTrue
        .ForeColor.RGB = Cells(7, i + 1).Interior.Color
        .Transparency = 0
    End With
    If Group(1, i) <> "" Then
        key = Group(1, i)
        If (Not o2.exists(key)) Then
            k = k + 1
            ReDim Preserve shpsArr(1 To 2, 1 To k)
            o2.Add key, k

            ReDim Preserve shpNames(1 To 1)
            shpNames(1) = shp.Name
            shpsArr(1, k) = shpNames
            
            shpsArr(2, k) = Group(1, i)
        Else
            n = UBound(shpsArr(1, o2(key))) + 1
            
            shpNames = shpsArr(1, o2(key))
            ReDim Preserve shpNames(1 To n)
            shpNames(n) = shp.Name
            shpsArr(1, o2(key)) = shpNames
        End If
    End If
Next i
For i = 1 To UBound(shpsArr, 2)
    shpNames = shpsArr(1, i)
    If (UBound(shpNames) > 1) Then
        Set gr = ActiveSheet.Shapes.Range(shpNames).Group
        gr.Name = shpsArr(2, i)
    End If
Next i
End Sub
[/vba]


Много чего не знаю!!!!

Сообщение отредактировал Roman777 - Вторник, 30.10.2018, 11:34
 
Ответить
СообщениеВасилисаЛукьянчикова,
[vba]
Код
Sub Макрос1()
Dim key$, o2
Dim lastcol
Dim c_x1y1, c_x2y2, Color1, Group
Dim shp

Dim shpNames() As String, shpsArr() 'массив массивов (двумерный), хранилище всех шейпов (имён)
Dim k&, n&

lastcol = Cells(2, Columns.Count).End(xlToLeft).Column

c_x1y1 = Range(Cells(2, 2), Cells(3, lastcol))
c_x2y2 = Range(Cells(5, 2), Cells(6, lastcol))
Color1 = Range(Cells(7, 2), Cells(7, lastcol))
Group = Range(Cells(8, 2), Cells(8, lastcol))

Set o2 = CreateObject("Scripting.Dictionary") ' будет флагом о том, встречали ли мы такую группу или нет

ReDim shpsArr(1 To 2, 1 To 1)
For i = 1 To lastcol - 1
    
Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, c_x1y1(1, i), c_x1y1(2, i), c_x2y2(1, i), c_x2y2(2, i)) '.Select
    With shp.Fill
        .Visible = msoTrue
        .ForeColor.RGB = Cells(7, i + 1).Interior.Color
        .Transparency = 0
    End With
    If Group(1, i) <> "" Then
        key = Group(1, i)
        If (Not o2.exists(key)) Then
            k = k + 1
            ReDim Preserve shpsArr(1 To 2, 1 To k)
            o2.Add key, k

            ReDim Preserve shpNames(1 To 1)
            shpNames(1) = shp.Name
            shpsArr(1, k) = shpNames
            
            shpsArr(2, k) = Group(1, i)
        Else
            n = UBound(shpsArr(1, o2(key))) + 1
            
            shpNames = shpsArr(1, o2(key))
            ReDim Preserve shpNames(1 To n)
            shpNames(n) = shp.Name
            shpsArr(1, o2(key)) = shpNames
        End If
    End If
Next i
For i = 1 To UBound(shpsArr, 2)
    shpNames = shpsArr(1, i)
    If (UBound(shpNames) > 1) Then
        Set gr = ActiveSheet.Shapes.Range(shpNames).Group
        gr.Name = shpsArr(2, i)
    End If
Next i
End Sub
[/vba]

Автор - Roman777
Дата добавления - 30.10.2018 в 11:11
ВасилисаЛукьянчикова Дата: Вторник, 30.10.2018, 18:33 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 36
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Roman777, спасибо.
 
Ответить
СообщениеRoman777, спасибо.

Автор - ВасилисаЛукьянчикова
Дата добавления - 30.10.2018 в 18:33
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Группировка объектов записанных в таблицу по тексту строки (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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