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

Вход

Регистрация

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

 

= Мир MS Excel/Макрос. Подчет количества объединенных ячеек - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос. Подчет количества объединенных ячеек
Макрос. Подчет количества объединенных ячеек
Michelangelo Дата: Понедельник, 28.02.2011, 23:33 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

Всем привет)))
На этот раз вот такой вопросик.
Например я по вертикале объединил несколько ячеек. Необходимо написать функцию которая будет подсчитывать количество объединенных ячеек.
Ну и работать она должна примерно так.

Задается первая по порядку (сверху в низ) ячейка из какого то количества обедненных ячеек.
Заводится счетчик , который и будет подсчитываться количество ячеек.
Ну и потом циклически надо идти в низ пока "объединена ячейка" не закончится.

По факту у меня загвоздка в условии остановки цикла))

 
Ответить
СообщениеВсем привет)))
На этот раз вот такой вопросик.
Например я по вертикале объединил несколько ячеек. Необходимо написать функцию которая будет подсчитывать количество объединенных ячеек.
Ну и работать она должна примерно так.

Задается первая по порядку (сверху в низ) ячейка из какого то количества обедненных ячеек.
Заводится счетчик , который и будет подсчитываться количество ячеек.
Ну и потом циклически надо идти в низ пока "объединена ячейка" не закончится.

По факту у меня загвоздка в условии остановки цикла))


Автор - Michelangelo
Дата добавления - 28.02.2011 в 23:33
Alex_ST Дата: Вторник, 01.03.2011, 10:00 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3198
Репутация: 606 ±
Замечаний: 0% ±

2003
Что-то у меня замороченно, ИМХО, получается...
Явно можно проще...
Но пока так:
Code
Sub MergeCells_Count()
    Dim rCell As Range, i&, sAddress$
    For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)
       If rCell.MergeCells Then
          If rCell.MergeArea.Address <> sAddress Then
             sAddress = rCell.MergeArea.Address
             i = i + 1
          End If
       End If
    Next
    MsgBox i
End Sub



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеЧто-то у меня замороченно, ИМХО, получается...
Явно можно проще...
Но пока так:
Code
Sub MergeCells_Count()
    Dim rCell As Range, i&, sAddress$
    For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)
       If rCell.MergeCells Then
          If rCell.MergeArea.Address <> sAddress Then
             sAddress = rCell.MergeArea.Address
             i = i + 1
          End If
       End If
    Next
    MsgBox i
End Sub

Автор - Alex_ST
Дата добавления - 01.03.2011 в 10:00
Alex_ST Дата: Вторник, 01.03.2011, 10:14 | Сообщение № 3
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3198
Репутация: 606 ±
Замечаний: 0% ±

2003
Можно, конечно, и так:
Code
Sub MergeCells_Count2()
    Dim rCell As Range, rRange As Range
    For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)
       If rCell.MergeCells Then
          If rRange Is Nothing Then
             Set rRange = rCell.MergeArea
          Else
             Set rRange = Union(rRange, rCell.MergeArea)
          End If
       End If
    Next
    MsgBox rRange.Areas.Count
End Sub

но тоже, ИМХО, как-то сложновато.



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеМожно, конечно, и так:
Code
Sub MergeCells_Count2()
    Dim rCell As Range, rRange As Range
    For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)
       If rCell.MergeCells Then
          If rRange Is Nothing Then
             Set rRange = rCell.MergeArea
          Else
             Set rRange = Union(rRange, rCell.MergeArea)
          End If
       End If
    Next
    MsgBox rRange.Areas.Count
End Sub

но тоже, ИМХО, как-то сложновато.

Автор - Alex_ST
Дата добавления - 01.03.2011 в 10:14
Hugo Дата: Вторник, 01.03.2011, 23:41 | Сообщение № 4
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3250
Репутация: 707 ±
Замечаний: 0% ±

2019
Алексей, а если адреса в словарь? smile

Code
Sub MergeCells_CountDic()
       Dim rCell As Range

       With New Dictionary ' Раннее связывание, нужен Reference на MS Scripting Runtime

           For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)
               If rCell.MergeCells Then
                   If Not .Exists(rCell.MergeArea.Address) Then .Add rCell.MergeArea.Address, 0
               End If
           Next
       MsgBox .Count
       End With
End Sub

Можно чуть сократить, ты умеешь smile


excel@nxt.ru
webmoney: E265281470651 Z422237915069
 
Ответить
СообщениеАлексей, а если адреса в словарь? smile

Code
Sub MergeCells_CountDic()
       Dim rCell As Range

       With New Dictionary ' Раннее связывание, нужен Reference на MS Scripting Runtime

           For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)
               If rCell.MergeCells Then
                   If Not .Exists(rCell.MergeArea.Address) Then .Add rCell.MergeArea.Address, 0
               End If
           Next
       MsgBox .Count
       End With
End Sub

Можно чуть сократить, ты умеешь smile

Автор - Hugo
Дата добавления - 01.03.2011 в 23:41
KuklP Дата: Среда, 02.03.2011, 09:45 | Сообщение № 5
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
А я так понял, что надо посчитать к-во ячеек в объединении:
Code
Public Function MyMergeCount(cMerge As Range)
     MyMergeCount = cMerge.MergeArea.Count
End Function

Но может я и не прав...


Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728


Сообщение отредактировал KuklP - Среда, 02.03.2011, 09:45
 
Ответить
СообщениеА я так понял, что надо посчитать к-во ячеек в объединении:
Code
Public Function MyMergeCount(cMerge As Range)
     MyMergeCount = cMerge.MergeArea.Count
End Function

Но может я и не прав...

Автор - KuklP
Дата добавления - 02.03.2011 в 09:45
Alex_ST Дата: Среда, 02.03.2011, 13:38 | Сообщение № 6
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3198
Репутация: 606 ±
Замечаний: 0% ±

2003
Quote (Hugo)
Алексей, а если адреса в словарь?

Игорь, хоть я и люблю словари (ты на это намекаешь, как я понял?) но не настолько же чтобы "из пушки по воробьям" biggrin
KuklP, Серёга, если бы ножно было посчитать общее число ячеек в объединённых областях, то никто бы с циклами, естественно, не заморачивался... Аналогичное твоему предложению решение у меня получилось уже через пару минут после того, как решил попробовать помочь. Но я подумал, что с таким элементарным вопросом топик-стартер обращаться бы не стал.

Хотя... Michelangelo поставил вопрос так, что трудно точно понять, что он хочет, посчитать кол-во ячеек в объединённых областях или кол-во объединенных областей.




С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
Сообщение
Quote (Hugo)
Алексей, а если адреса в словарь?

Игорь, хоть я и люблю словари (ты на это намекаешь, как я понял?) но не настолько же чтобы "из пушки по воробьям" biggrin
KuklP, Серёга, если бы ножно было посчитать общее число ячеек в объединённых областях, то никто бы с циклами, естественно, не заморачивался... Аналогичное твоему предложению решение у меня получилось уже через пару минут после того, как решил попробовать помочь. Но я подумал, что с таким элементарным вопросом топик-стартер обращаться бы не стал.

Хотя... Michelangelo поставил вопрос так, что трудно точно понять, что он хочет, посчитать кол-во ячеек в объединённых областях или кол-во объединенных областей.


Автор - Alex_ST
Дата добавления - 02.03.2011 в 13:38
Michelangelo Дата: Среда, 02.03.2011, 13:47 | Сообщение № 7
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

Попробую переформулировать вопрос...)))
Нужно посчитать количество обедненных ячеек в области отдельно по вертикали(по столбцу), и отдельно по горизонтале (по строке).

Ну на всякий случай пример. Например объединяю диапазон А1:B4 . в этом случае функция по горизантале должна вернуть 2, а функция по вертикале 4

 
Ответить
СообщениеПопробую переформулировать вопрос...)))
Нужно посчитать количество обедненных ячеек в области отдельно по вертикали(по столбцу), и отдельно по горизонтале (по строке).

Ну на всякий случай пример. Например объединяю диапазон А1:B4 . в этом случае функция по горизантале должна вернуть 2, а функция по вертикале 4


Автор - Michelangelo
Дата добавления - 02.03.2011 в 13:47
Hugo Дата: Среда, 02.03.2011, 13:59 | Сообщение № 8
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3250
Репутация: 707 ±
Замечаний: 0% ±

2019
Алексей, хоть и из пушки, но вроде покороче код получается.
А угадал похоже Сергей smile


excel@nxt.ru
webmoney: E265281470651 Z422237915069
 
Ответить
СообщениеАлексей, хоть и из пушки, но вроде покороче код получается.
А угадал похоже Сергей smile

Автор - Hugo
Дата добавления - 02.03.2011 в 13:59
Hugo Дата: Среда, 02.03.2011, 14:07 | Сообщение № 9
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3250
Репутация: 707 ±
Замечаний: 0% ±

2019
Только у меня такой вариант функции Сергея получился smile :

Code
Public Function MyMergeCount2(cMerge As Range)
Dim cc As Range
For Each cc In cMerge
With cc.MergeArea
          If .MergeCells Then
           MyMergeCount2 = MyMergeCount2 + 1
          End If
End With
Next
End Function

P.S. Попроще можно (вложение заменил):

Code
Public Function MyMergeCount2(cMerge As Range)
Dim cc As Range
For Each cc In cMerge
        If cc.MergeCells Then
         MyMergeCount2 = MyMergeCount2 + 1
        End If
Next
End Function
К сообщению приложен файл: MyMergeCount2-.zip (6.4 Kb)


excel@nxt.ru
webmoney: E265281470651 Z422237915069
 
Ответить
СообщениеТолько у меня такой вариант функции Сергея получился smile :

Code
Public Function MyMergeCount2(cMerge As Range)
Dim cc As Range
For Each cc In cMerge
With cc.MergeArea
          If .MergeCells Then
           MyMergeCount2 = MyMergeCount2 + 1
          End If
End With
Next
End Function

P.S. Попроще можно (вложение заменил):

Code
Public Function MyMergeCount2(cMerge As Range)
Dim cc As Range
For Each cc In cMerge
        If cc.MergeCells Then
         MyMergeCount2 = MyMergeCount2 + 1
        End If
Next
End Function

Автор - Hugo
Дата добавления - 02.03.2011 в 14:07
Alex_ST Дата: Среда, 02.03.2011, 14:13 | Сообщение № 10
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3198
Репутация: 606 ±
Замечаний: 0% ±

2003
И, к стати, если уж использовать словари, то, наверное, лучше так:
Code
Function MergeAreas(rRange As Range)
    Dim rCell As Range
    With CreateObject("Scripting.Dictionary")  ' создаем временный словарь
       For Each rCell In Intersect(rRange, ActiveSheet.UsedRange)
          If rCell.MergeCells Then
             .Item(rCell.MergeArea.Address) = ""  ' попытка записи значения по отсутствующему ключу добавит ключ в словарь
          End If
       Next
       MergeAreas = .Count
    End With
End Function

или так:
Code
Sub MergeCells_CountDic()
    Dim rCell As Range
    With CreateObject("Scripting.Dictionary")  ' создаем временный словарь
       For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)
          If rCell.MergeCells Then
             .Item(rCell.MergeArea.Address) = ""  ' попытка записи значения по отсутствующему ключу добавит ключ в словарь
          End If
       Next
       MsgBox .Count
    End With
End Sub



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеИ, к стати, если уж использовать словари, то, наверное, лучше так:
Code
Function MergeAreas(rRange As Range)
    Dim rCell As Range
    With CreateObject("Scripting.Dictionary")  ' создаем временный словарь
       For Each rCell In Intersect(rRange, ActiveSheet.UsedRange)
          If rCell.MergeCells Then
             .Item(rCell.MergeArea.Address) = ""  ' попытка записи значения по отсутствующему ключу добавит ключ в словарь
          End If
       Next
       MergeAreas = .Count
    End With
End Function

или так:
Code
Sub MergeCells_CountDic()
    Dim rCell As Range
    With CreateObject("Scripting.Dictionary")  ' создаем временный словарь
       For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)
          If rCell.MergeCells Then
             .Item(rCell.MergeArea.Address) = ""  ' попытка записи значения по отсутствующему ключу добавит ключ в словарь
          End If
       Next
       MsgBox .Count
    End With
End Sub

Автор - Alex_ST
Дата добавления - 02.03.2011 в 14:13
Hugo Дата: Среда, 02.03.2011, 14:15 | Сообщение № 11
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3250
Репутация: 707 ±
Замечаний: 0% ±

2019
Так я про то и говорил - проверять попытками, а не проверкой. Я сам там хромаю... Ты спец.


excel@nxt.ru
webmoney: E265281470651 Z422237915069
 
Ответить
СообщениеТак я про то и говорил - проверять попытками, а не проверкой. Я сам там хромаю... Ты спец.

Автор - Hugo
Дата добавления - 02.03.2011 в 14:15
Alex_ST Дата: Среда, 02.03.2011, 14:17 | Сообщение № 12
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3198
Репутация: 606 ±
Замечаний: 0% ±

2003
Прошу прощения, свой предыдущий пост оставил, не обновив экран, поэтому не видел, что появились ответы.

P.S.
к стати, Игорь, если, как меня научили гуру на Планете, использовать конструкцию типа

Code
With CreateObject("Scripting.Dictionary")
...
End With
, то и код не усложняется введением дополнительных
Code
Dim oDict as Object : Set oDoct = CreateObject("Scripting.Dictionary")
...
Set oDoct = Nothing
и не надо заморачиваться ранним связыванием (ссылками в Reference) и возможностью проблем если вдруг на другом компе не связано.



С уважением,
Алексей
MS Excel 2003 - the best!!!


Сообщение отредактировал Alex_ST - Среда, 02.03.2011, 14:31
 
Ответить
СообщениеПрошу прощения, свой предыдущий пост оставил, не обновив экран, поэтому не видел, что появились ответы.

P.S.
к стати, Игорь, если, как меня научили гуру на Планете, использовать конструкцию типа

Code
With CreateObject("Scripting.Dictionary")
...
End With
, то и код не усложняется введением дополнительных
Code
Dim oDict as Object : Set oDoct = CreateObject("Scripting.Dictionary")
...
Set oDoct = Nothing
и не надо заморачиваться ранним связыванием (ссылками в Reference) и возможностью проблем если вдруг на другом компе не связано.

Автор - Alex_ST
Дата добавления - 02.03.2011 в 14:17
KuklP Дата: Четверг, 03.03.2011, 08:29 | Сообщение № 13
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
В одну строчку:
Code
Public Function MyMergeCount(cMerge As Range) As String
      MyMergeCount = UBound(cMerge.MergeArea.Formula) & ", " & UBound(cMerge.MergeArea.Formula, 2)
End Function

Через запятую к-во строк, столбцов.


Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеВ одну строчку:
Code
Public Function MyMergeCount(cMerge As Range) As String
      MyMergeCount = UBound(cMerge.MergeArea.Formula) & ", " & UBound(cMerge.MergeArea.Formula, 2)
End Function

Через запятую к-во строк, столбцов.

Автор - KuklP
Дата добавления - 03.03.2011 в 08:29
Alex_ST Дата: Четверг, 03.03.2011, 09:24 | Сообщение № 14
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3198
Репутация: 606 ±
Замечаний: 0% ±

2003
Quote (KuklP)
В одну строчку

Серёга, попытался разобраться в твоей формуле - не понял, что должно вернуть UBound(cMerge.MergeArea.Formula) ?
Как это ты у возвращаемой формулы в нотации А1 определяешь верхнюю границу массива? При этом в одной и той же строке сначала - одномерного, а потом двумерного? Решил, что должно дать ошибку.
Засомневался в своих теоретических знаниях. Решил проверить на практике - попробовал тупо вставить в стандартный модуль. Как и ожидал - ошибка. В модуль листа - тоже.
Что-то ты либо недописал, либо перемудрил.



С уважением,
Алексей
MS Excel 2003 - the best!!!


Сообщение отредактировал Alex_ST - Четверг, 03.03.2011, 09:26
 
Ответить
Сообщение
Quote (KuklP)
В одну строчку

Серёга, попытался разобраться в твоей формуле - не понял, что должно вернуть UBound(cMerge.MergeArea.Formula) ?
Как это ты у возвращаемой формулы в нотации А1 определяешь верхнюю границу массива? При этом в одной и той же строке сначала - одномерного, а потом двумерного? Решил, что должно дать ошибку.
Засомневался в своих теоретических знаниях. Решил проверить на практике - попробовал тупо вставить в стандартный модуль. Как и ожидал - ошибка. В модуль листа - тоже.
Что-то ты либо недописал, либо перемудрил.

Автор - Alex_ST
Дата добавления - 03.03.2011 в 09:24
KuklP Дата: Четверг, 03.03.2011, 09:42 | Сообщение № 15
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
Смотри. Ошибка там, где и должна быть - где нет объединенных.
К сообщению приложен файл: merge.xls (20.5 Kb)


Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеСмотри. Ошибка там, где и должна быть - где нет объединенных.

Автор - KuklP
Дата добавления - 03.03.2011 в 09:42
Alex_ST Дата: Четверг, 03.03.2011, 10:10 | Сообщение № 16
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3198
Репутация: 606 ±
Замечаний: 0% ±

2003
Да, действительно...
Просто я чтобы не связываться с листом, проверял твою функцию с помощью
Code
Sub ttt()
Debug.Print MyMergeCount(ActiveSheet.[A1])
End Sub

А ActiveSheet когда пробовал в модуле листа опустил. Вот и не работало.

Но всё равно НЕ ПОНИМАЮ что воэвращает UBound(cMerge.MergeArea.Formula) ?
Ведь .Formula "Returns or sets the object's formula in A1-style notation and in the language of the macro"

МАССИВОМ (а ведь это должен быть массив, иначе какой же у него UBound ?) какой размерности является значение, возвращаемое cMerge.MergeArea.Formula ?
Если одномерный, то почему не ругается UBound по второму измерению? А если двумерный, то почему не ругается UBound без указания измерения?




С уважением,
Алексей
MS Excel 2003 - the best!!!


Сообщение отредактировал Alex_ST - Четверг, 03.03.2011, 10:14
 
Ответить
СообщениеДа, действительно...
Просто я чтобы не связываться с листом, проверял твою функцию с помощью
Code
Sub ttt()
Debug.Print MyMergeCount(ActiveSheet.[A1])
End Sub

А ActiveSheet когда пробовал в модуле листа опустил. Вот и не работало.

Но всё равно НЕ ПОНИМАЮ что воэвращает UBound(cMerge.MergeArea.Formula) ?
Ведь .Formula "Returns or sets the object's formula in A1-style notation and in the language of the macro"

МАССИВОМ (а ведь это должен быть массив, иначе какой же у него UBound ?) какой размерности является значение, возвращаемое cMerge.MergeArea.Formula ?
Если одномерный, то почему не ругается UBound по второму измерению? А если двумерный, то почему не ругается UBound без указания измерения?


Автор - Alex_ST
Дата добавления - 03.03.2011 в 10:10
KuklP Дата: Четверг, 03.03.2011, 10:32 | Сообщение № 17
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
Смотри.
Quote
Если одномерный, то почему не ругается UBound по второму измерению? А если двумерный, то почему не ругается UBound без указания измерения?

Многомерный массив без указания размерности вернет UBound первой размерности. Можешь проверить.
К сообщению приложен файл: 2519470.gif (10.9 Kb)


Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728


Сообщение отредактировал KuklP - Четверг, 03.03.2011, 10:36
 
Ответить
СообщениеСмотри.
Quote
Если одномерный, то почему не ругается UBound по второму измерению? А если двумерный, то почему не ругается UBound без указания измерения?

Многомерный массив без указания размерности вернет UBound первой размерности. Можешь проверить.

Автор - KuklP
Дата добавления - 03.03.2011 в 10:32
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос. Подчет количества объединенных ячеек
  • Страница 1 из 1
  • 1
Поиск:

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