Страницы: 1
RSS
оптимизация алгоритма функции VBA
 
Добрый день. Помогите пожалуйста оптимизировать код функции. Описание и пример в приложении. Заранее благодарен.
 
А зачем VBA-функция нужна?  
С этим легко и формулы справятся:  
=СУММ(Лист2:Лист6!I8)  
 
Только листы добавляйте МЕЖДУ существующих листов (Лист2 и Лист6)  
Ну или создайте 2 пустых листа (первый и последний), и в формуле укажите их названия.  
 
Пример в файле: http://excelvba.ru/XL_Files/Sample__15-07-2011__17-46-42.zip
 
Теперь эти листы (с именами НАЧАЛО и КОНЕЦ) можно скрыть - и добавлять новые листы даже после последнего видимого листа.  
Формулы будут считать корректно (и быстрее, чем ваша UDF)  
 
Пример в файле: http://excelvba.ru/XL_Files/Sample__15-07-2011__17-47-50.zip
 
{quote}{login=EducatedFool}{date=15.07.2011 03:49}{thema=}{post}Теперь эти листы (с именами НАЧАЛО и КОНЕЦ) можно скрыть - и добавлять новые листы даже после последнего видимого листа.  
Формулы будут считать корректно (и быстрее, чем ваша UDF)  
 
Пример в файле: http://excelvba.ru/XL_Files/Sample__15-07-2011__17-47-50.zip{/post}{/quote}  
 
Всё гениальное - просто :)  
Спасибо. Не знал что так можно сделать.  
Попробовал, работает. :)
 
Эх ..., а выбрасывать жалко:
 
С.М.,  
а в чем смысл использования пользовательского типа, состоящего из одной переменной?  
Если определить переменные как Variant:  
Dim Cubes(), Cube,  
и убрать везде ".Т", работает так же.
 
{quote}{login=С.М.}{date=15.07.2011 05:24}{thema=Re: Re: }{post}Эх ..., а выбрасывать жалко:{/post}{/quote}  
 
Спасибо и Вам! :)  
Жаль научить некому, если бы знал получше может и сам бы разобрался.  
Ещё раз всем большой спасибо :)
 
Убрал ".T", жму компилировать - ругань.  
Погорячился с названием пользов.типа - Cube - запутался в измерениях, надо было назвать Table - вроде как срез куба.  
Вот чуть покороче и ЮзерТип заменил на Коллекцию:  
'  
Function СуммЯчеекТаблиц2(ByVal ИмяТаблицы As String, Optional АвтоПересчет As Boolean = True)  
Rem Функция суммирует значения ячеек одинаково-именованных диапазонов на листах активной книги.  
   Dim WBk As Workbook, Ts As New Collection, T, Sh As Worksheet, TRng As Range, S() As Double  
   Dim N As Integer, M As Integer, TCnt As Integer, I As Integer, J As Integer, K As Integer  
   '  
   Application.Volatile АвтоПересчет  
   Set WBk = Application.Caller.Parent.Parent  
   On Error Resume Next  
   For Each Sh In WBk.Worksheets  
       Set TRng = Sh.Names(ИмяТаблицы).RefersToRange  
       If Not TRng Is Nothing Then  
           Ts.Add TRng.Value  
           Set TRng = Nothing  
       End If  
   Next  
   On Error GoTo ErrExit  
   N = UBound(Ts(1), 1)  
   M = UBound(Ts(1), 2)  
   ReDim S(1 To N, 1 To M)  
   For Each T In Ts  
       For J = 1 To M  
           For I = 1 To N  
               S(I, J) = S(I, J) + T(I, J)  
           Next  
       Next  
   Next  
   СуммЯчеекТаблиц2 = S  
   On Error GoTo 0  
   Exit Function  
ErrExit:  
   Err.Clear  
   СуммЯчеекТаблиц2 = CVErr(xlErrValue)  
End Function
 
{quote}{login=Казанский}{date=15.07.2011 07:18}{thema=}{post}С.М.,  
а в чем смысл использования пользовательского типа, состоящего из одной переменной?  
Если определить переменные как Variant:  
Dim Cubes(), Cube,  
и убрать везде ".Т", работает так же.{/post}{/quote}  
Алексей, невнимательно прочитал Ваше замечание.  
Dim Cubes(), Cube  
и убрать везде ".Т" - работает.
 
> Dim Cubes(), Cube ...  
Ух-ты!  
Получается, что ReDim Preserve Массив(Первое_измерение) ?  
 
А как же строгое "изменять можно только верхнюю границу ПОСЛЕДНЕГО измерения массива" в руководствах по VB/VBA ?
 
Это же одномерный массив. У него первое измерение - оно же и последнее :)  
Другое дело, что массив массивов вообще не нужен. Считали массив с листа - сложили - дальше пошли.  
Неплохо бы добавить проверку на IsNumeric и размер считанного массива, вдруг они разные.
 
{quote}{login=Казанский}{date=15.07.2011 09:12}{thema=}{post}Это же одномерный массив. У него первое измерение - оно же и последнее :){/post}{/quote}  
Алексей, спасибо - уже понял.  
{quote}{login=Казанский}{date=15.07.2011 09:12}{thema=}{post}Другое дело, что массив массивов вообще не нужен. Считали массив с листа - сложили - дальше пошли.{/post}{/quote}  
Здесь не понял: до начала цикла по листам не известна геометрия выходного массива S(), можно конечно цикл прервать на первом попавшем, с нужном диапазоном, а смысл ?    
{quote}{login=Казанский}{date=15.07.2011 09:12}{thema=}{post}Неплохо бы добавить проверку на IsNumeric и размер считанного массива, вдруг они разные.{/post}{/quote}  
Проверку на  IsNumeric делает On Error GoTo ErrExit [S() As Double], а проверку на размеры, да, надо добавить.
 
> Это же одномерный массив. У него первое измерение - оно же и последнее :)  
  Алексей, спасибо - уже понял.  
 
> Другое дело, что массив массивов вообще не нужен. Считали массив с листа - сложили - дальше пошли.  
  Здесь не понял: до начала цикла по листам не известна геометрия выходного массива S(), можно конечно цикл прервать на первом попавшем, с нужном диапазоном, а смысл ?    
 
> Неплохо бы добавить проверку на IsNumeric и размер считанного массива, вдруг они разные.  
  Проверку на  IsNumeric делает On Error GoTo ErrExit [S() As Double], а проверку на размеры, да, надо добавить.
 
Как-то так:  
'  
Function СуммЯчеекТаблиц(ByVal ИмяТаблицы As String, Optional АвтоПересчет As Boolean = True)  
Rem Суммирует значения ячеек одинаково-именованных и с одинаковой структурой диапазонов-таблиц на листах книги.  
   Dim Ts(), T(), Sh As Worksheet, TRng As Range, S() As Double  
   Dim N As Integer, M As Integer, TCnt As Integer, I As Integer, J As Integer, K As Integer  
   '  
   Application.Volatile АвтоПересчет  
   On Error Resume Next  
   For Each Sh In Application.Caller.Parent.Parent.Worksheets  
       Set TRng = Sh.Names(ИмяТаблицы).RefersToRange  
       If Not TRng Is Nothing Then  
           TCnt = TCnt + 1  
           ReDim Preserve Ts(1 To TCnt)  
           Ts(TCnt) = TRng.Value  
           Set TRng = Nothing  
       End If  
   Next  
   On Error GoTo ErrExit  
   N = UBound(Ts(1), 1)  
   M = UBound(Ts(1), 2)  
   ReDim S(1 To N, 1 To M)  
   For K = 1 To TCnt  
       T = Ts(K)  
       If UBound(T, 1) <> N Or UBound(T, 2) <> M Then GoTo ErrExit  
       For J = 1 To M  
           For I = 1 To N  
               S(I, J) = S(I, J) + T(I, J)  
           Next  
       Next  
   Next  
   СуммЯчеекТаблиц = S  
   On Error GoTo 0  
   Exit Function  
ErrExit:  
   Err.Clear  
   СуммЯчеекТаблиц = CVErr(xlErrValue)  
End Function
 
Мой вариант. Размер выходного массива задается размером диапазона, в который вставлена функция. Именованный диапазоны на разных листах могут иметь разный размер и могут содержать нечисловые значения. См. файл.  
 
Function СуммЯчеекТаблиц3(ByVal ИмяТаблицы As String, Optional АвтоПересчет As Boolean = True)  
' Суммирует значения ячеек одинаково-именованных и с одинаковой структурой диапазонов-таблиц на листах книги.  
   Dim T(), Sh As Worksheet, S() As Double, I As Integer, J As Integer  
   '  
   Application.Volatile АвтоПересчет  
   On Error Resume Next  
   With Application.Caller  
       ReDim S(1 To .Rows.Count, 1 To .Columns.Count)  
       For Each Sh In .Parent.Parent.Worksheets  
           T = Sh.Names(ИмяТаблицы).RefersToRange.Value  
           If Err = 0 Then  
               For J = 1 To Application.Min(UBound(T, 2), UBound(S, 2))  
                   For I = 1 To Application.Min(UBound(T, 1), UBound(S, 1))  
                       S(I, J) = S(I, J) + T(I, J)  
                   Next  
               Next  
           End If  
           Err.Clear  
       Next  
   End With  
   СуммЯчеекТаблиц3 = S  
End Function
 
файл
 
Алексей, категорически с Вами не согласен.  
Это что получается, юзвер вместо 287 забивает в ячейку текст "Бла-бла" и из семейного бюджета  
выпадает эта сумма.  
Или, удаляет в одной из таблиц несколько строк, и у партии "КоммунистыЗаКапитализм"  
пропадают 487239 голосов избирателей.  
А функция должна кричать: "подлог !"  
:-)
 
соглашусь, с EducatedFool - зачем изобретать велосипед)  
 
Если исходить из макроса автора темы, то я бы сделал так (при условии, что суммируются только целые числа (результат в пределах от -32768 до +32767), и с первого листа нет нужды брать данные):  
 
Public Function SumOfSheets%(ByRef objCell As Object)  
Dim objSheet As Object  
For Each objSheet In Worksheets  
   If Not objSheet Is ActiveSheet Then  
       SumOfSheets = SumOfSheets + objSheet.Range(objCell.Address)  
   End If  
Next  
End Function
Чебурашка стал символом олимпийских игр. А чего достиг ты?
Тишина - самый громкий звук


https://github.com/nervgh
 
nerv, так Вы против "изобретения велосипеда" или за (если предлагаете свой вариант) ?  
{quote}{login=EducatedFool}{date=15.07.2011 03:47}{thema=}{post}А зачем VBA-функция нужна?  
С этим легко и формулы справятся:  
=СУММ(Лист2:Лист6!I8)  
Пример в файле: http://excelvba.ru/XL_Files/Sample__15-07-2011__17-46-42.zip{/post}{/quote}
 
Попробую прояснить: в целом против) Но если все-таки автор (темы) хочет макрос, то (как вариант) выше.
Чебурашка стал символом олимпийских игр. А чего достиг ты?
Тишина - самый громкий звук


https://github.com/nervgh
 
С другой стороны, я считаю, что в целях развития, иной раз, бывает полезно его изобретать : )
Чебурашка стал символом олимпийских игр. А чего достиг ты?
Тишина - самый громкий звук


https://github.com/nervgh
 
:-)
Страницы: 1
Читают тему
Наверх
Loading...