Option
Explicit
Const
E_KRONECKERPROD_INVALID_ARG
As
Long
= XlCVError.xlErrRef
Public
Sub
TestRun()
Dim
result
As
Variant
Dim
retVal
As
Variant
With
Worksheets(
"Tabelle1"
)
retVal = KroneckerProd(.Range(
"B2:L12"
), .Range(
"O2:Y12"
), result)
If
Not
IsError(retVal)
Then
.Range(
"B15"
).Resize(UBound(result), UBound(result, 2)).Value = result
Else
Select
Case
CLng
(retVal)
Case
E_KRONECKERPROD_INVALID_ARG
Call
MsgBox(
"invalid argument(s)"
, vbCritical)
Case
Else
Call
MsgBox(
CStr
(retVal), vbCritical)
End
Select
End
If
End
With
End
Sub
Public
Function
KroneckerProd(ArgA
As
Variant
, ArgB
As
Variant
,
ByRef
RetArg
As
Variant
)
As
Variant
Dim
vA, vB
On
Error
Resume
Next
vA = ArgA: vB = ArgB
On
Error
GoTo
0
If
IsArray(vA)
And
IsArray(vB)
Then
ReDim
RetArg(1
To
(UBound(vA) - LBound(vA) + 1) * (UBound(vB) - LBound(vB) + 1), _
1
To
(UBound(vA, 2) - LBound(vA, 2) + 1) * (UBound(vB, 2) - LBound(vB, 2) + 1))
KroneckerProd = KroneckerProd__(vA, vB, RetArg)
If
IsEmpty(KroneckerProd)
Then
KroneckerProd = 0
Else
KroneckerProd = CVErr(E_KRONECKERPROD_INVALID_ARG)
End
If
End
Function
Private
Function
KroneckerProd__(ArgA
As
Variant
, ArgB
As
Variant
,
ByRef
ArgC
As
Variant
,
Optional
Idx1,
Optional
Idx2)
As
Variant
Dim
i&, j&, m&, n&
If
IsArray(ArgA)
And
IsArray(ArgB)
Then
If
Not
(IsMissing(Idx1)
Or
IsMissing(Idx2))
Then
m = (UBound(ArgB) - LBound(ArgB) + 1)
n = (UBound(ArgB, 2) - LBound(ArgB, 2) + 1)
For
i = 1
To
m
For
j = 1
To
n
ArgC(i + (Idx1 - 1) * m, j + (Idx2 - 1) * n) = ArgA(Idx1, Idx2) * ArgB(i, j)
Next
j, i
Else
For
i = 1
To
UBound(ArgA) - LBound(ArgA) + 1
For
j = 1
To
UBound(ArgA, 2) - LBound(ArgA, 2) + 1
Call
KroneckerProd__(ArgA, ArgB, ArgC, i, j)
Next
j, i
End
If
Else
KroneckerProd__ = CVErr(E_KRONECKERPROD_INVALID_ARG)
End
If
End
Function