KeyCoder, у вас в коде несоответствие типов (из функции CanonCalc первым атрибутом передается массив, а в функции Kramer к нему применяется метод Rows и Columns, для которых нужен объект Range) [vba]
Код
Function Kramer(A As Variant, B As Variant) As Variant Dim i As Integer Dim j As Integer Dim k As Integer Dim ARowCount As Integer Dim BRowCount As Integer
Dim detA As Double Dim ColNo As Integer
Dim DeltaMatrix() As Double Dim res As Variant
If TypeOf A Is Range Then A = A.Value ElseIf Not IsArray(A) Then MsgBox "Не задана матрица X" Exit Function End If If TypeOf B Is Range Then B = B.Value ElseIf Not IsArray(B) Then MsgBox "Не задан вектор-столбец Y" Exit Function Else: ReDim Preserve B(UBound(B), 1) End If With Application If .Count(A) <> .CountA(A) Then MsgBox "Не все элементы матрицы X являются распознаваемыми как числа. Возможно, какой-то из элементов введен неправильно" Exit Function ElseIf .Count(B) <> .CountA(B) Then MsgBox "Не все элементы вектора-столбца Y являются распознаваемыми как числа. Возможно, какой-то из элементов введен неправильно" Exit Function ElseIf UBound(A) <> UBound(B) Then MsgBox "количество строк в векторе-столбце Y и матрице X не совпадает. Видимо, был выделен неправильный диапазон чисел" Exit Function ElseIf UBound(A, 1) <> UBound(A, 2) Then MsgBox "Матрица X не является квадратной. Вычисление определителя невозможно" Exit Function End If ColNo = UBound(A) detA = .MDeterm(A)
ReDim res(1 To ColNo)
If detA = 0 Then MsgBox "Определитель матрицы равен нулю. Метод Крамера невыполним." Exit Function End If
For i = 1 To ColNo For j = 1 To ColNo Debug.Print ("Hello world") Next j Next i
For i = 1 To ColNo ReDim DeltaMatrix(1 To ColNo, 1 To ColNo)
For k = 1 To ColNo For j = 1 To ColNo DeltaMatrix(k, j) = A(k, j) Next j Next k
For j = 1 To ColNo DeltaMatrix(j, i) = B(j, 1) Next j
res(i) = .MDeterm(DeltaMatrix) / detA Next i Kramer = .Transpose(res) End With End Function
[/vba]
KeyCoder, у вас в коде несоответствие типов (из функции CanonCalc первым атрибутом передается массив, а в функции Kramer к нему применяется метод Rows и Columns, для которых нужен объект Range) [vba]
Код
Function Kramer(A As Variant, B As Variant) As Variant Dim i As Integer Dim j As Integer Dim k As Integer Dim ARowCount As Integer Dim BRowCount As Integer
Dim detA As Double Dim ColNo As Integer
Dim DeltaMatrix() As Double Dim res As Variant
If TypeOf A Is Range Then A = A.Value ElseIf Not IsArray(A) Then MsgBox "Не задана матрица X" Exit Function End If If TypeOf B Is Range Then B = B.Value ElseIf Not IsArray(B) Then MsgBox "Не задан вектор-столбец Y" Exit Function Else: ReDim Preserve B(UBound(B), 1) End If With Application If .Count(A) <> .CountA(A) Then MsgBox "Не все элементы матрицы X являются распознаваемыми как числа. Возможно, какой-то из элементов введен неправильно" Exit Function ElseIf .Count(B) <> .CountA(B) Then MsgBox "Не все элементы вектора-столбца Y являются распознаваемыми как числа. Возможно, какой-то из элементов введен неправильно" Exit Function ElseIf UBound(A) <> UBound(B) Then MsgBox "количество строк в векторе-столбце Y и матрице X не совпадает. Видимо, был выделен неправильный диапазон чисел" Exit Function ElseIf UBound(A, 1) <> UBound(A, 2) Then MsgBox "Матрица X не является квадратной. Вычисление определителя невозможно" Exit Function End If ColNo = UBound(A) detA = .MDeterm(A)
ReDim res(1 To ColNo)
If detA = 0 Then MsgBox "Определитель матрицы равен нулю. Метод Крамера невыполним." Exit Function End If
For i = 1 To ColNo For j = 1 To ColNo Debug.Print ("Hello world") Next j Next i
For i = 1 To ColNo ReDim DeltaMatrix(1 To ColNo, 1 To ColNo)
For k = 1 To ColNo For j = 1 To ColNo DeltaMatrix(k, j) = A(k, j) Next j Next k
For j = 1 To ColNo DeltaMatrix(j, i) = B(j, 1) Next j
res(i) = .MDeterm(DeltaMatrix) / detA Next i Kramer = .Transpose(res) End With End Function
Option Explicit Dim rng As Range Private Sub hook() Dim obj As Object For Each obj In Me.ScrollBars.ShapeRange With obj.OLEFormat.Object Set rng = Union(IIf(rng Is Nothing, Range(.LinkedCell), rng), Range(.LinkedCell)) End With Next For Each obj In Me.OLEObjects If TypeOf obj.Object Is MSForms.ScrollBar Then Set rng = Union(IIf(rng Is Nothing, Range(obj.LinkedCell), rng), Range(obj.LinkedCell)) End If Next [A1].Formula = "=sum(" & rng.Address & ")" End Sub Private Sub Worksheet_Calculate() If rng Is Nothing Then Call hook With Application: .EnableEvents = False If .Average(rng) <> rng.Areas(1)(1, 1) Then rng.Value = IIf(.Min(rng) = .Median(rng), .Max(rng), .Min(rng)) End If .EnableEvents = True: End With End Sub
[/vba]
можно как-то так (наверно...)
[vba]
Код
Option Explicit Dim rng As Range Private Sub hook() Dim obj As Object For Each obj In Me.ScrollBars.ShapeRange With obj.OLEFormat.Object Set rng = Union(IIf(rng Is Nothing, Range(.LinkedCell), rng), Range(.LinkedCell)) End With Next For Each obj In Me.OLEObjects If TypeOf obj.Object Is MSForms.ScrollBar Then Set rng = Union(IIf(rng Is Nothing, Range(obj.LinkedCell), rng), Range(obj.LinkedCell)) End If Next [A1].Formula = "=sum(" & rng.Address & ")" End Sub Private Sub Worksheet_Calculate() If rng Is Nothing Then Call hook With Application: .EnableEvents = False If .Average(rng) <> rng.Areas(1)(1, 1) Then rng.Value = IIf(.Min(rng) = .Median(rng), .Max(rng), .Min(rng)) End If .EnableEvents = True: End With End Sub
Option Explicit Public col As Collection Public Sub hook() Dim wsh As Worksheet, rng As Range, obj As Object, tmp$(), i& Set col = New Collection With Application: .EnableEvents = False: .ScreenUpdating = False For Each wsh In Sheets Set rng = Nothing If wsh.ScrollBars.Count Then For Each obj In wsh.ScrollBars.ShapeRange With obj.OLEFormat.Object ReDim Preserve tmp(i) tmp(i) = wsh.Range(.LinkedCell).Address(, , , True) Set rng = Union(IIf(rng Is Nothing, Range(tmp(i)), rng), Range(tmp(i))) i = i + 1 End With Next End If For Each obj In wsh.OLEObjects If TypeOf obj.Object Is MSForms.ScrollBar Then ReDim Preserve tmp(i) tmp(i) = wsh.Range(obj.LinkedCell).Address(, , , True) Set rng = Union(IIf(rng Is Nothing, Range(tmp(i)), rng), Range(tmp(i))) i = i + 1 End If Next col.Add rng, wsh.Name Next With ActiveSheet Sheets().Select [A1].Activate ActiveCell.Formula = "=sum(" & Join(tmp, ",") & ")" .Select End With .EnableEvents = True: .ScreenUpdating = True: End With End Sub
[/vba]
[vba]
Код
Option Explicit Private Sub Workbook_SheetCalculate(ByVal Sh As Object) Dim rr As Range, rg As Range If Not Sh Is ActiveSheet Then Exit Sub If col Is Nothing Then Call hook With Application: .EnableEvents = False Set rg = col(Sh.Name) If .Average(rg) <> rg.Areas(1)(1, 1) Or rg.Count = 1 Then For Each rr In col Sheets(rr.Parent.Name).Range(rr.Address).Value = IIf(.Min(rg) = .Median(rg), .Max(rg), .Min(rg)) Next End If .EnableEvents = True: End With End Sub
[/vba]
чего-то я немного разошелся
[vba]
Код
Option Explicit Public col As Collection Public Sub hook() Dim wsh As Worksheet, rng As Range, obj As Object, tmp$(), i& Set col = New Collection With Application: .EnableEvents = False: .ScreenUpdating = False For Each wsh In Sheets Set rng = Nothing If wsh.ScrollBars.Count Then For Each obj In wsh.ScrollBars.ShapeRange With obj.OLEFormat.Object ReDim Preserve tmp(i) tmp(i) = wsh.Range(.LinkedCell).Address(, , , True) Set rng = Union(IIf(rng Is Nothing, Range(tmp(i)), rng), Range(tmp(i))) i = i + 1 End With Next End If For Each obj In wsh.OLEObjects If TypeOf obj.Object Is MSForms.ScrollBar Then ReDim Preserve tmp(i) tmp(i) = wsh.Range(obj.LinkedCell).Address(, , , True) Set rng = Union(IIf(rng Is Nothing, Range(tmp(i)), rng), Range(tmp(i))) i = i + 1 End If Next col.Add rng, wsh.Name Next With ActiveSheet Sheets().Select [A1].Activate ActiveCell.Formula = "=sum(" & Join(tmp, ",") & ")" .Select End With .EnableEvents = True: .ScreenUpdating = True: End With End Sub
[/vba]
[vba]
Код
Option Explicit Private Sub Workbook_SheetCalculate(ByVal Sh As Object) Dim rr As Range, rg As Range If Not Sh Is ActiveSheet Then Exit Sub If col Is Nothing Then Call hook With Application: .EnableEvents = False Set rg = col(Sh.Name) If .Average(rg) <> rg.Areas(1)(1, 1) Or rg.Count = 1 Then For Each rr In col Sheets(rr.Parent.Name).Range(rr.Address).Value = IIf(.Min(rg) = .Median(rg), .Max(rg), .Min(rg)) Next End If .EnableEvents = True: End With End Sub
С Днем Победы! Вас хочу поздравить с Днем победы! Очень это праздник непростой, Ведь за мир наш погибали деды, Жертвуя всей жизнью молодой. Чтобы дальше люди жили в мире, Чтобы больше не было войны, Сколько люди жизней положили - Все об этом помнить мы должны.
С Днем Победы! Вас хочу поздравить с Днем победы! Очень это праздник непростой, Ведь за мир наш погибали деды, Жертвуя всей жизнью молодой. Чтобы дальше люди жили в мире, Чтобы больше не было войны, Сколько люди жизней положили - Все об этом помнить мы должны.krosav4ig
Если искомого значения в одном из столбцов может не быть, то меня массивная формула 175 обнаружился косяк, 182 без "=" Формула не протягиваемая Плюс макрофункция 118 символов
Если искомого значения в одном из столбцов может не быть, то меня массивная формула 175 обнаружился косяк, 182 без "=" Формула не протягиваемая Плюс макрофункция 118 символовkrosav4ig
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
) 
