При изменении аргументов пользовательской функции вылетает Excel

@alexmosc · Регистрация: 14.10.2012

Author24 — интернет-сервис помощи студентам

Коллеги, добрый день!

Могли бы вы подсказать непрофессионалу в VBA, почему при изменении аргументов функции (полный код мой - приведен ниже) на листе Excel книга часто сразу же закрывается без указания конкретной причины сбоя.

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

Может я использую неправильную обработку данных в макросе?

Visual Basic

Function тоталкоррел(x As Range) As Variant
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.DisplayStatusBar = False
    Application.DisplayAlerts = False
 
'=тоталкоррел(диапазон)
 
Dim x1 As Variant
Dim x_marginal As String
Dim length As Long
Dim width As Long
Dim counter As Integer
Dim h As Long
Dim hh As Long
Dim hhh As Long
Dim hhhh As Long
Dim hhhhh As Long
Dim w As Long
Dim ww As Long
Dim x1_concatenated_collect As New Collection, a
Dim x1_marginal_collect As New Collection, b
Dim concatenated_probability As Double
Dim marginal_probability As Double
Dim totalcorrel As Double
 
x1 = x.Value
 
length = UBound(x1, 1)
 
width = UBound(x1, 2)
 
    'creating an array of concatenated elements
 
ReDim x1_concatenated(length, 1) As String
 
    For h = 1 To length
        For w = 1 To width
            x1_concatenated(h, 1) = x1_concatenated(h, 1) & x1(h, w)
        Next w
    Next h
 
    'creating a collection of concatenated elements
 
On Error Resume Next
    For Each a In x1_concatenated
        x1_concatenated_collect.Add a, Str(a)
    Next
 
    'creating an array of concatenated element probabilities
 
ReDim x1_concatenated_prob(x1_concatenated_collect.Count, 1) As Double
 
For h = 1 To x1_concatenated_collect.Count
    For hh = 1 To length
        If x1_concatenated(hh, 1) = x1_concatenated_collect(h) Then
            x1_concatenated_prob(h, 1) = x1_concatenated_prob(h, 1) + 1 / length
            Else
        End If
    Next hh
Next h
 
    'calculating big cyle
    
    For h = 1 To x1_concatenated_collect.Count
    
        marginal_probability = 1
        
        For counter = 1 To width
        
            x_marginal = Mid(x1_concatenated_collect(h), counter, 1)
            
            ReDim x1_marginal(length, 1) As String
            
            For hh = 1 To length
                x1_marginal(hh, 1) = x1(hh, counter)
            Next hh
            
            On Error Resume Next
            For Each b In x1_marginal
                x1_marginal_collect.Add b, Str(b)
            Next
            
            ReDim x1_marginal_prob(x1_marginal_collect.Count, 1) As Double
            
            For hhh = 1 To x1_marginal_collect.Count
                For hhhh = 1 To length
                    If x1_marginal(hhhh, 1) = x1_marginal_collect(hhh) Then
                        x1_marginal_prob(hhh, 1) = x1_marginal_prob(hhh, 1) + 1 / length
                        Else
                    End If
                Next hhhh
            Next hhh
            
            hhhhh = 1
            Do Until x_marginal = x1_marginal_collect(hhhhh) Or hhhhh = x1_marginal_collect.Count
                hhhhh = hhhhh + 1
            Loop
            
            marginal_probability = marginal_probability * x1_marginal_prob(hhhhh, 1)
            
        Next counter
                    
        totalcorrel = totalcorrel + x1_concatenated_prob(h, 1) * WorksheetFunction.Log(x1_concatenated_prob(h, 1) / marginal_probability, 2)
 
    Next h
 
тоталкоррел = totalcorrel
 
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True
    Application.DisplayStatusBar = True
    Application.DisplayAlerts = True
 
End Function

@alexmosc · 09.10.2014, 12:13 **[ТС]**

Файл с примером работы прилагаю.

SoftIce · 09.10.2014, 13:30

Сообщение от alexmosc

книга часто сразу же закрывается без указания конкретной причины сбоя.

Я код не смотрел, но если книга тихо умирает по неизвестной причине, то зачем вы выключаете алерты?

Visual Basic

1	Application.DisplayAlerts = False

@alexmosc · 09.10.2014, 13:50 **[ТС]**

Да, логично.

Попробовал убрать отключение алертов.

Все равно тихо вылетает книга. Скриншот прикрепил.

В общем, если объем обсчитываемых данных - маленький, например, 10 строк на 3 столбца, то все считается. Если там 1000 строк и значения в строки добавляются через другие формулы на листе, то изменение в аргументах используемых функций приводит к схлапыванию книги.

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

SoftIce · 09.10.2014, 14:53

On Error resume next тоже ясности не добавит.

@alexmosc · 09.10.2014, 15:45 **[ТС]**

О, убрал эту конструкцию и поведение изменилось. Теперь возвращает #ЗНАЧ!

Буду смотреть теперь дальше сам.

Спасибо.

Добавлено через 22 минуты
Применительно к указанной конструкции построения коллекции, этот рецепт я взял с форума:

Visual Basic

On Error Resume Next
    For Each a In x1_concatenated
        x1_concatenated_collect.Add a, Str(a)
    Next

И там же был комментарий относительно

Visual Basic

1	On Error Resume Next

"Worth adding (even at this late date) that Collections can be unique, as long as you use the second Key argument when adding items. Key values must always be unique, and adding an item with an existing Key raises an error:hence the On Error Resume Next"

(http://stackoverflow.com/quest... from-array)

То есть, коллекция из уникальных значений собирается как раз правильно, когда обработка ошибки есть.

SoftIce · 09.10.2014, 16:16

Сообщение от alexmosc

коллекция из уникальных значений собирается как раз правильно, когда обработка ошибки есть

Да, но ее действие распространяется на весь нижеследующий код. Нужно ли Вам это? Может лучше сделать так:

Visual Basic

On Error goto m
    For Each a In x1_concatenated
        x1_concatenated_collect.Add a, Str(a)
    Next
m:

@alexmosc · 09.10.2014, 16:51 **[ТС]**

А мне кажется при ошибке в моем оригинале программа продолжает с Next и соответственно идет на новый цикл. И если метку поставить после цикла, то собственно заполнение коллекции прервется при первом повторном элементе.

Но в целом, я понял, о чем Вы говорите. Конечно, такая обработка ошибки на весь код мне не нужна.

SoftIce · 09.10.2014, 17:42

Сообщение от alexmosc

заполнение коллекции прервется при первом повторном элементе.

Так?

Visual Basic

    For Each a In x1_concatenated
     On Error goto m
        x1_concatenated_collect.Add a, Str(a)
m:
    Next

@alexmosc · 09.10.2014, 19:06 **[ТС]**

Сегодня весь день копался, и слушал Вас, также.

Перепилил, в общем, код. Сделал не коллекцию, а dictionary. С коллекцией возникли дополнительные странности, когда попробовал ее заполнять текстовыми строками.

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

Visual Basic

    Option Explicit
    Option Base 1
 
Function тоталкоррел(x As Range) As Variant
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.DisplayStatusBar = False
    'Application.DisplayAlerts = False
 
'=òîòàëêîððåë(äèàïàçîí)
 
Dim NumberOfRows As Long
Dim NumberOfColumns As Long
Dim x_marginal_array() As String
Dim x_marginal As String
Dim length As Long
Dim width As Long
Dim counter As Integer
Dim h As Long
Dim hh As Long
Dim hhh As Long
Dim hhhh As Long
Dim hhhhh As Long
Dim w As Long
Dim ww As Long
Dim concatenated_probability As Double
Dim marginal_probability As Double
Dim totalcorrel As Double
 
Dim d As New Scripting.Dictionary
Dim dd As New Scripting.Dictionary
Dim a As Variant
Dim aa As Variant
 
NumberOfRows = x.Rows.Count
NumberOfColumns = x.Columns.Count
 
ReDim x1(NumberOfRows, NumberOfColumns) As String
 
For h = 1 To NumberOfRows
    For w = 1 To NumberOfColumns
        x1(h, w) = CStr(x.Cells(h, w))
    Next w
Next h
 
length = UBound(x1, 1)
 
width = UBound(x1, 2)
 
    'creating an array of concatenated elements
 
ReDim x1_concatenated(length, 1) As String
 
    For h = 1 To length
        For w = 1 To width
            If w < width Then
                x1_concatenated(h, 1) = x1_concatenated(h, 1) & x1(h, w) & ";"
                Else
                x1_concatenated(h, 1) = x1_concatenated(h, 1) & x1(h, w)
            End If
        Next w
    Next h
 
    With d
        .CompareMode = TextCompare
        For Each a In x1_concatenated
            If Not Len(a) = 0 And Not .Exists(a) Then
                .Add a, Nothing
            End If
        Next a
    End With
 
    'creating an array of concatenated element probabilities
 
ReDim x1_concatenated_prob(d.Count, 1) As Double
 
For h = 1 To d.Count
    For hh = 1 To length
        If x1_concatenated(hh, 1) = d.keys(h - 1) Then
            x1_concatenated_prob(h, 1) = x1_concatenated_prob(h, 1) + 1 / length
            Else
        End If
    Next hh
Next h
 
    'calculating big cyle
    
    For h = 1 To d.Count
        
        x_marginal_array = Split(d.keys(h - 1), ";")
        
        marginal_probability = 1
        
        For counter = 1 To width
            
            x_marginal = x_marginal_array(counter - 1)
            
            ReDim x1_marginal(length, 1) As String
            
            For hh = 1 To length
                x1_marginal(hh, 1) = x1(hh, counter)
            Next hh
            
            With dd
                .CompareMode = TextCompare
                For Each aa In x1_marginal
                    If Not Len(aa) = 0 And Not .Exists(aa) Then
                        .Add aa, Nothing
                    End If
                Next aa
            End With
            
            ReDim x1_marginal_prob(dd.Count, 1) As Double
            
            For hhh = 1 To dd.Count
                For hhhh = 1 To length
                    If x1_marginal(hhhh, 1) = dd.keys(hhh - 1) Then
                        x1_marginal_prob(hhh, 1) = x1_marginal_prob(hhh, 1) + 1 / length
                        Else
                    End If
                Next hhhh
            Next hhh
            
            hhhhh = 1
            Do Until x_marginal = dd.keys(hhhhh - 1) Or hhhhh = dd.Count
                hhhhh = hhhhh + 1
            Loop
            
            marginal_probability = marginal_probability * x1_marginal_prob(hhhhh, 1)
            
        Next counter
                    
        totalcorrel = totalcorrel + x1_concatenated_prob(h, 1) * WorksheetFunction.Log(x1_concatenated_prob(h, 1) / marginal_probability, 2)
 
    Next h
 
тоталкоррел = totalcorrel
 
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True
    Application.DisplayStatusBar = True
    'Application.DisplayAlerts = True
 
End Function

Пока не разу не вылетела книга. Щас еще потестирую.

@alexmosc 4 / 4 / 1 Регистрация: 14.10.2012 Сообщений: 95
	09.10.2014, 13:50 [ТС]	4
	Да, логично. Попробовал убрать отключение алертов. Все равно тихо вылетает книга. Скриншот прикрепил. В общем, если объем обсчитываемых данных - маленький, например, 10 строк на 3 столбца, то все считается. Если там 1000 строк и значения в строки добавляются через другие формулы на листе, то изменение в аргументах используемых функций приводит к схлапыванию книги. При этом если числа в массиве заданы простой функцией, например, случмежду(), то все считается нормально даже на больших массивах. Миниатюры 0

SoftIce es geht mir gut 11270 / 4752 / 1183 Регистрация: 27.07.2011 Сообщений: 11,439
	09.10.2014, 14:53	5
	On Error resume next тоже ясности не добавит. 0

@alexmosc 4 / 4 / 1 Регистрация: 14.10.2012 Сообщений: 95
	09.10.2014, 16:51 [ТС]	8
	А мне кажется при ошибке в моем оригинале программа продолжает с Next и соответственно идет на новый цикл. И если метку поставить после цикла, то собственно заполнение коллекции прервется при первом повторном элементе. Но в целом, я понял, о чем Вы говорите. Конечно, такая обработка ошибки на весь код мне не нужна. 0

	09.10.2014, 19:06

Опции темы