Poker Dealer Logic - excel

I'd like to use Excel as my poker dealer. Here is the code that will generate 20 random numbers (cards) between 1 and 52. Output of first 20 numbers/cards is in column A1:A20. I'd like to have the next set of 20 numbers/cards generated in A22:A41, 3rd A43:A62, and so on. How can the code be fixed so that it displays 1000 hands in column A with one row separating each set? Thank you.
Sub cards()
Range("A:A").Clear
cardstodraw = 20
For x = 1 To cardstodraw
begL:
ActiveSheet.Cells(1, 2) = "=Randbetween(1,52)"
ActiveSheet.Cells(x, 1) = ActiveSheet.Cells(1, 2).Text
cardvalue = ActiveSheet.Cells(x, 1)
y = 1
Count = 0
Do Until ActiveSheet.Cells(y, 1) = ""
If ActiveSheet.Cells(y, 1) = cardvalue Then
Count = Count + 1
End If: y = y + 1: Loop
If Count > 1 Then GoTo begL
Next
Range("B1").Clear
End Sub

Your code is somewhat convoluted (using GoTo is usually an indication that something can be improved). For getting a sample of size 20 from 1-52, use a modified Fisher-Yates shuffle:
Option Explicit 'you really should be using this
Function deal(n As Long, k As Long) As Variant
'returns an array of length k
'consisting of k numbers in the range 1 to n
Dim deck As Variant
Dim i As Long, j As Long, temp As Long
ReDim deck(1 To n)
For i = 1 To n
deck(i) = i
Next i
With Application.WorksheetFunction
'do k steps of a Fisher-Yates shuffle on deck
For i = 1 To .Min(k, n - 1)
j = .RandBetween(i, n)
If i < j Then 'swap
temp = deck(i)
deck(i) = deck(j)
deck(j) = temp
End If
Next i
End With
ReDim Preserve deck(1 To k)
deal = deck
End Function
If you want to have 1000 hands in Column A:
Sub ManyHands()
Dim i As Long
With Application.WorksheetFunction
For i = 1 To 1000
Range(Cells(1 + 21 * (i - 1), 1), Cells(21 * i - 1, 1)).Value = .Transpose(deal(52, 20))
Next i
End With
End Sub
On Edit Here is a modified version of the code, one which deals cards to multiple players:
Function deal(n As Long, k As Long, players As Long) As Variant
'returns an array with k rows and players columns
'consisting of k*players numbers in range 1 to n
'if players = 1, then the array is 1-dimensional
'otherwise it is 2-dimensional
Dim deck As Variant
Dim i As Long, j As Long, temp As Long
Dim hands As Variant
ReDim deck(1 To n)
For i = 1 To n
deck(i) = i
Next i
With Application.WorksheetFunction
'do k*players steps of a Fisher-Yates shuffle on deck
For i = 1 To .Min(k * players, n - 1)
j = .RandBetween(i, n)
If i < j Then 'swap
temp = deck(i)
deck(i) = deck(j)
deck(j) = temp
End If
Next i
End With
ReDim Preserve deck(1 To k * players)
If players = 1 Then
deal = deck
Exit Function
Else
ReDim hands(1 To k, 1 To players)
For i = 1 To k
For j = 1 To players
hands(i, j) = deck(players * (i - 1) + j)
Next j
Next i
deal = hands
End If
End Function
It could be used like:
Sub ManyHands()
Dim i As Long
For i = 1 To 1000
Range(Cells(1 + 11 * (i - 1), 1), Cells(11 * i - 1, 2)).Value = deal(52, 10, 2)
Next i
End Sub

Try:
Sub cards()
Dim cardstodraw As Long, numberofhands As Long, i As Long, j As Long, k As Long
cardstodraw = 20
numberofhands = 50
Range("A:A").Clear
With Application.WorksheetFunction
For j = 0 To numberofhands - 1
For i = 1 To cardstodraw
begL:
Cells(i + k + (j * cardstodraw), 1) = .RandBetween(1, 52)
If .CountIf(Range(Cells(1 + k + (j * cardstodraw), 1), Cells(20 + k + (j * cardstodraw), 1)), Cells(i + k + (j * cardstodraw), 1)) > 1 Then GoTo begL
Next i
k = k + 1
Next j
End With
End Sub

Related

Repeat range Nth times

I am trying to devise a code that enables me to repeat a range (of one column) to be repeated Nth times. This is my try (and it is working) but I need your ideas to improve the code if possible
Sub Test()
Const N As Integer = 3
Dim a, i As Long, ii As Long, k As Long
a = ActiveSheet.Range("A1:A" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row).Value
ReDim b(1 To UBound(a, 1) * N, 1 To 1)
For i = 1 To N
For ii = LBound(a, 1) To UBound(a, 1)
k = k + 1
b(k, 1) = a(ii, 1)
Next ii
Next i
Range("C1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
I would do it similarly...
Sub Test()
Dim a, c&, i&, k&
Const n& = 3
a = [a1].Resize(Cells(Rows.Count, 1).End(xlUp).Row)
ReDim b(1 To n * UBound(a), 1 To 1)
For k = 1 To n
For i = 1 To UBound(a)
c = c + 1
b(c, 1) = a(i, 1)
Next
Next
[c1].Resize(UBound(b)) = b
End Sub
But it would be best to make it into an encapsulated procedure...
Sub Test()
CloneRange [a1], [c1], 3
End Sub
Sub CloneRange(rSrc As Range, rDst As Range, Optional n& = 1)
Dim a, c&, i&, k&
a = rSrc.Resize(Cells(Rows.Count, 1).End(xlUp).Row)
ReDim b(1 To n * UBound(a), 1 To 1)
For k = 1 To n
For i = 1 To UBound(a)
c = c + 1
b(c, 1) = a(i, 1)
Next
Next
rDst.Resize(UBound(b)) = b
End Sub

VBA - Finding all order combinations and count

I have a worksheet with over 60,000 rows and two columns. One column is transaction id, the other is item. I want to find the combinations of items in the orders. I found this vba code from someone with a similar problem
Sub basket()
On Error Resume Next
Dim ps(2, 20)
r = 3
tr = Cells(2, 1)
Item = Cells(2, 2) + "."
ps(1, 1) = 1
ps(2, 1) = Len(Item)
r2 = 2
r3 = 3
ic = 2
While Cells(r, 1) <> ""
If Cells(r, 1) <> tr Then
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
Item = ""
ic = 1
tr = Cells(r, 1)
End If
ps(1, ic) = Len(Item) + 1
ps(2, ic) = Len(Cells(r, 2)) + 1
Item = Item + Cells(r, 2) + "."
r = r + 1
ic = ic + 1
Wend
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
End Sub
Which worked when I ran the exact same code but with item categories. The problem is I'm running it with the item names and it's always crashing my Excel. Is there anyone that can guide me in the right direction?
this is the worksheet that doesn't work
this is what I get when I run it with the item category which works. They're the exact same data, one just has it as item category, and the other is item name.
Your code sample didn't do anything for me. It ran, but it didn't actually produce any kind of results at all. I did a quick Google search and found this.
Sub ListCombinations()
Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long
Set sht = ActiveSheet
'lists begin in A1, B1, C1, D1
For Each c In sht.Range("A2:B2").Cells
col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
numCols = numCols + 1
Next c
res = Combine(col, "~~")
For i = 0 To UBound(res)
arr = Split(res(i), "~~")
sht.Range("H1").Offset(i, 0).Resize(1, numCols) = arr
Next i
End Sub
'create combinations from a collection of string arrays
Function Combine(col As Collection, SEP As String) As String()
Dim rv() As String
Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
Dim t As Long, i As Long, n As Long, ub As Long
Dim numIn As Long, s As String, r As Long
numIn = col.Count
ReDim pos(1 To numIn)
ReDim lbs(1 To numIn)
ReDim ubs(1 To numIn)
ReDim lengths(1 To numIn)
t = 0
For i = 1 To numIn 'calculate # of combinations, and cache bounds/lengths
lbs(i) = LBound(col(i))
ubs(i) = UBound(col(i))
lengths(i) = (ubs(i) - lbs(i)) + 1
pos(i) = lbs(i)
t = IIf(t = 0, lengths(i), t * lengths(i))
Next i
ReDim rv(0 To t - 1) 'resize destination array
For n = 0 To (t - 1)
s = ""
For i = 1 To numIn
s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
Next i
rv(n) = s
For i = numIn To 1 Step -1
If pos(i) <> ubs(i) Then 'Not done all of this array yet...
pos(i) = pos(i) + 1 'Increment array index
For r = i + 1 To numIn 'Reset all the indexes
pos(r) = lbs(r) ' of the later arrays
Next r
Exit For
End If
Next i
Next n
Combine = rv
End Function
I found that from this link.
VBA - Write all possible combinations of 4 columns of data
I'm pretty sure if you do some more Googling, you can find other concepts that do pretty much the same thing.

Excel vba - joining two arrays

I need to join two arrays vd and vd1 into vdu.
ReDim vdu(1 To (UBound(vd, 1) + UBound(vd1, 1)), 1 To 1)
For i = 1 To UBound(vd, 1)
vdu(i, 1) = vd(i, 1)
Next i
For j = i To UBound(vdu, 1)
vdu(j, 1) = vd1(j - i + 1, 1)
Next j
First, I get and "out of range" error.
Second, in the end I will have 18 arrays that I'll need to join, so I don't know if this is the best idea for joining them.
try with
ReDim vdu(LBound(vd) To UBound(vd) + UBound(vd1), 1 To 1)
For i = LBound(vdu) To UBound(vdu)
If i <= UBound(vd) Then
vdu(i, 1) = vd(i, 1)
Else
vdu(i, 1) = vd1(i - UBound(vd), 1)
End If
Next i
Update for second part of question
I'd convert your merge code into a function
Public Function MergeArrays(arr1 As Variant, arr2 As Variant) As Variant
Dim i As Long
Dim arr As Variant
ReDim arr(LBound(arr1, 1) To UBound(arr1, 1) + UBound(arr2, 1), 1 To 1)
For i = LBound(arr, 1) To UBound(arr, 1)
If i <= UBound(arr1, 1) Then
arr(i, 1) = arr1(i, 1)
Else
arr(i, 1) = arr2(i - UBound(arr1, 1), 1)
End If
Next i
MergeArrays = arr
End Function
And then pass each array to it 1 at a time e.g.
arr = MergeArrays(vd1, vd2)
arr = MergeArrays(arr, vd3)
arr = MergeArrays(arr, vdx)
You could loop through this by storing your arrays in an array or dictionary and looping through that instead as well
Other option
Public Function MergeArrays(ParamArray arrays() As Variant) As Variant
Dim i As Long, j As Long, cnter As Long, UBoundArr As Long, OldUBoundArray As Long
Dim arr() As Variant
For j = LBound(arrays) To UBound(arrays)
UBoundArr = UBoundArr + UBound(arrays(j), 1)
Next j
ReDim arr(1 To UBoundArr, 1 To 1)
For j = LBound(arrays) To UBound(arrays)
For i = LBound(arrays(j)) To UBound(arrays(j))
arr(i + OldUBoundArray, 1) = arrays(j)(i, 1)
Next i
OldUBoundArray = OldUBoundArray + UBound(arrays(j), 1)
Next j
MergeArrays = arr
End Function
This method uses a ParamArray. If you're not sure what that is look it up but effectively you're able to pass an unspecified amount of arguments to the function. Therefore with this function you can combine any amount of arrays (of the same shape and same base i.e. x to x, 1 to 1) and it will combine them. Call like
arr = MergeArrays(vd, vd1, vd2,....,vd18)
getMasterArray will return an array that combines up to 60 different 2d arrays into one. getMasterArray also give you the option of returning a 0 or based array.
Sub TestgetMasterArray()
Dim data
data = getMasterArray(False, Range("List1").Value, Range("List2").Value, Range("List3").Value, Range("List4").Value)
Worksheets("Result").Range("A1").Resize(UBound(data), UBound(data, 2)).Value = data
End Sub
Function getMasterArray(Base0 As Boolean, ParamArray Arrays() As Variant)
Dim result As Variant, v As Variant
Dim Count As Long, Count2 As Long, lowBound As Integer, lOffset As Integer, x As Long, x1 As Long, y As Long
For Each v In Arrays
Count = Count + UBound(v) + IIf(LBound(v) = 0, 1, 0)
y = UBound(v, 2) + IIf(LBound(v, 2) = 0, 1, 0)
If y > Count2 Then Count2 = y
Next
lowBound = IIf(Base0, 0, 1)
ReDim result(lowBound To Count, lowBound To Count2)
For Each v In Arrays
If LBound(v, 2) > LBound(result, 2) Then
lOffset = -1
ElseIf LBound(v, 2) < LBound(result, 2) Then
lOffset = 1
End If
For x = LBound(v) To UBound(v)
For y = LBound(v, 2) To UBound(v, 2)
result(lowBound, y + lOffset) = v(x, y)
Next
lowBound = lowBound + 1
Next
Next
getMasterArray = result
End Function
Sample data generated by ockaroo.com

Splitting the data into 3 parts randomly - Excel

I have a dataset in an Excel sheet and i need to RANDOMLY split this (for instance 999 records) into 3 equal (and no duplicates) Excel files. Can this be done simply by using some Excel function or I need to write code to specifically do this?
Sometimes low-tech is best. If you don't need to repeat this very frequently...
add a column to the dataset, fill with =RAND()
sort the dataset on this column
copy the first 333 rows into a new sheet
copy the next 333 rows into a new sheet
I bet that would take less time than you've already spent trying to get the macros to work.
This revised macro will take the original 999 records and randomly distribute them into three other files (each file containing exactly 333 items) :
Sub croupier()
Dim k1 As Long, k2 As Long, k3 As Long
Dim Original As Workbook
Dim I As Long, ary(1 To 999)
Set Original = ActiveWorkbook
Dim rw As Long
Workbooks.Add
Set Winken = ActiveWorkbook
Workbooks.Add
Set Blinken = ActiveWorkbook
Workbooks.Add
Set Nod = ActiveWorkbook
k1 = 1
k2 = 1
k3 = 1
For I = 1 To 999
ary(I) = I
Next I
Call Shuffle(ary)
With Original.Sheets("Sheet1")
For I = 1 To 333
rw = ary(I)
.Cells(rw, 1).EntireRow.Copy Winken.Sheets("Sheet1").Cells(k1, 1)
k1 = k1 + 1
Next I
For I = 334 To 666
rw = ary(I)
.Cells(rw, 1).EntireRow.Copy Blinken.Sheets("Sheet1").Cells(k2, 1)
k2 = k2 + 1
Next I
For I = 667 To 999
rw = ary(I)
.Cells(rw, 1).EntireRow.Copy Nod.Sheets("Sheet1").Cells(k3, 1)
k3 = k3 + 1
Next I
End With
Winken.Save
Blinken.Save
Nod.Save
Winken.Close
Blinken.Close
Nod.Close
End Sub
Sub Shuffle(InOut() As Variant)
Dim HowMany As Long, I As Long, J As Long
Dim tempF As Double, temp As Variant
Hi = UBound(InOut)
Low = LBound(InOut)
ReDim Helper(Low To Hi) As Double
Randomize
For I = Low To Hi
Helper(I) = Rnd
Next I
J = (Hi - Low + 1) \ 2
Do While J > 0
For I = Low To Hi - J
If Helper(I) > Helper(I + J) Then
tempF = Helper(I)
Helper(I) = Helper(I + J)
Helper(I + J) = tempF
temp = InOut(I)
InOut(I) = InOut(I + J)
InOut(I + J) = temp
End If
Next I
For I = Hi - J To Low Step -1
If Helper(I) > Helper(I + J) Then
tempF = Helper(I)
Helper(I) = Helper(I + J)
Helper(I + J) = tempF
temp = InOut(I)
InOut(I) = InOut(I + J)
InOut(I + J) = temp
End If
Next I
J = J \ 2
Loop
End Sub
Here is a macro that will accept an array and copy to three different sheets:
Sub DoWork(Students As Variant)
Dim i As Long
Dim row As Integer
Dim sheetNumber As Integer
ReDim myArray(UBound(Students)) As Variant
Dim shuffledArray As Variant
Dim wkSheet As Worksheet
Dim myBooks(3) As Workbook
Set myBooks(1) = workBooks.Add
Set myBooks(2) = workBooks.Add
Set myBooks(3) = workBooks.Add
'populate the array with the number of rows
For i = 1 To UBound(Students)
myArray(i) = i
Next
'shuffle the array to provide true randomness
shuffledArray = ShuffleArray(myArray)
sheetNumber = 1
row = 1
'loop through the rows assiging to sheets
For i = 1 To UBound(Students)
If sheetNumber = 4 Then
sheetNumber = 1
row = row + 1
End If
Set wkSheet = myBooks(sheetNumber).ActiveSheet
wkSheet.Cells(row, 1) = Students(shuffledArray(i))
sheetNumber = sheetNumber + 1
Next
myBooks(1).SaveAs ("ws1.xlsx")
myBooks(2).SaveAs ("ws2.xlsx")
myBooks(3).SaveAs ("ws3.xlsx")
End Sub
Function ShuffleArray(InArray() As Variant) As Variant()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ShuffleArray
' This function returns the values of InArray in random order. The original
' InArray is not modified.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim N As Long
Dim Temp As Variant
Dim J As Long
Dim Arr() As Variant
Dim L As Long
Randomize
L = UBound(InArray) - LBound(InArray) + 1
ReDim Arr(LBound(InArray) To UBound(InArray))
For N = LBound(InArray) To UBound(InArray)
Arr(N) = InArray(N)
Next N
For N = LBound(Arr) To UBound(Arr)
J = CLng(((UBound(Arr) - N) * Rnd) + N)
Temp = Arr(N)
Arr(N) = Arr(J)
Arr(J) = Temp
Next N
ShuffleArray = Arr
End Function
Sub ShuffleArrayInPlace(InArray() As Variant)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ShuffleArrayInPlace
' This shuffles InArray to random order, randomized in place.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim N As Long
Dim L As Long
Dim Temp As Variant
Dim J As Long
Randomize
L = UBound(InArray) - LBound(InArray) + 1
For N = LBound(InArray) To UBound(InArray)
J = CLng(((UBound(InArray) - N) * Rnd) + N)
If N <> J Then
Temp = InArray(N)
InArray(N) = InArray(J)
InArray(J) = Temp
End If
Next N
End Sub
You would then call with something like this:
Option Explicit
Option Base 1
Sub Test()
Dim i As Long
Dim Students(999) As Variant
'populate the array with the number of rows
For i = 1 To UBound(Students)
Students(i) = "Students-" & Str(i)
Next
DoWork (Students)
End Sub

Linear system solving ( N*N matrix multiplication ), VBA

I have 2 arrays. Array1 is n * n and Array2 is 1 * n.
These arrays are given in worksheets. In this case Sheet3 and Sheet4 and I need to output the answer on Sheet5.
I get multiple errors like "Subscript out of range".
I can't seem to figure out why this isn't working:
Public Sub LinearSystemSolver()
x = Sheet3.UsedRange.Rows.Count
y = Sheet3.UsedRange.Columns.Count
Z = Sheet4.UsedRange.Rows.Count
Dim a As Variant
ReDim a(1 To x, 1 To y)
Dim b As Variant
ReDim b(1 To Z, 1 To 1)
Dim g As Variant
ReDim g(1 To Z, 1 To 1)
For i = 1 To x
For j = 1 To y
a(i, j) = Sheet3.Cells(i, j)
Next
Next
For f = 1 To Z
b(f,1) = Sheet4.Cells(f,1)
Next
g = Application.WorksheetFunction.MMult((Application.WorksheetFunction.MInverse(a)), b)
For h = 1 To Z
Sheet5.Cells(h, 1) = g(h, 1)
Next
End Sub
You can speed up your code by assigning to the arrays directly and avoid loops
a = Sheet3.Range("A1").Resize(x,y).Value
b = Sheet4.Range("A1").Resize(z,1).Value
...
Sheet5.Range("A1").Resize(z,1).Value = g
Now as far as inverting the matrix (if x=y=z) the I propose to use LU decomposition. I have attached a working example which I have used for many years.
The driver code is
Private Sub solveButton_Click()
Dim lu As New LuSolver
' Get Matrix values and decompose them into L, U, P form
' Values are in B3 and matrix is a 5×5 size
lu.IntializeFromRange Range("B3"), 5
' Solve the A*x=b matrix system for x
' right hand side is in J3 and it is a 5×1 size
' resulting 5×1 matrix will be placed under H3
lu.Solve Range("J3"), 1, Range("H3")
End Sub
with the LU solver in a class called 'LuSolver"
'---------------------------------------------------------------------------------------
' Module : LuSolver
' DateTime : 6/30/2008 13:01
' Author : ja72
' Purpose : LU Decomposition of rectangular matrix.
' Remarks:
'For an n-by-n matrix A, the LU decomposition is an n-by-n
'unit lower triangular matrix L, an n-by-n upper triangular matrix U,
'and a permutation vector piv of length n so that A(piv)=L*U.
'---------------------------------------------------------------------------------------
Option Explicit
Private lu As Variant
Private sign As Integer
Private pivot() As Integer
Private size As Integer
Private Sub Class_Initialize()
Set lu = Nothing
Erase pivot
sign = 1
End Sub
Private Sub Class_Terminate()
Set lu = Nothing
Erase pivot
sign = 0
End Sub
Public Sub IntializeFromRange(ByRef r_coef As Range, ByVal matrix_size As Integer)
Dim k_max As Integer, k As Integer, p As Integer
Dim i As Integer, j As Integer
Dim s As Variant
On Error GoTo IntializeFromRange_Error
lu = r_coef.Resize(matrix_size, matrix_size).Value
size = matrix_size
'Set pivot as a sequence of integers
ReDim pivot(1 To size)
For i = 1 To size
pivot(i) = i
Next i
sign = 1
For j = 1 To size
'Apply previous transformations
For i = 1 To size
If j > i Then k_max = i Else k_max = j
s = 0
'Time consuming dot product
For k = 1 To k_max - 1
s = s + lu(i, k) * lu(k, j)
Next k
lu(i, j) = lu(i, j) - s
Next i
'Find the pivot element
p = j
For i = j + 1 To size
If Abs(lu(i, j)) > Abs(lu(p, j)) Then
p = i
End If
Next i
'Exchange pivot rows
If p <> j Then
For k = 1 To size
s = lu(p, k)
lu(p, k) = lu(j, k)
lu(j, k) = s
Next k
k = pivot(p)
pivot(p) = pivot(j)
pivot(j) = k
sign = -sign
End If
'Compute Multipliers
s = lu(j, j)
If j <= size And s <> 0 And s <> 1 Then
For i = j + 1 To size
lu(i, j) = lu(i, j) / s
Next i
End If
Next j
On Error GoTo 0
Exit Sub
IntializeFromRange_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure IntializeFromRange of Class Module LuDecomposition"
End Sub
Public Property Get IsSingular() As Boolean
IsSingular = Not IsNonSingular
End Property
Public Property Get IsNonSingular() As Boolean
IsNonSingular = True
Dim j As Integer
For j = 1 To size
If lu(j, j) = 0 Then
IsNonSingular = False
Exit Property
End If
Next j
End Property
Public Sub Solve(ByRef r_rhs As Range, ByVal no_of_columns, ByRef r_result As Range)
On Error GoTo Solve_Error
Dim rhs As Variant
Dim N As Integer, M As Integer, r As Integer
Dim i As Integer, j As Integer, k As Integer
N = size
M = size
r = no_of_columns
rhs = r_rhs.Resize(size, r).Value
'Copy rhs with pivoting
Dim X As Variant
ReDim X(1 To size, 1 To r)
For i = 1 To size
For j = 1 To r
X(i, j) = rhs(pivot(i), j)
Next j
Next i
'Solve L*Y = B
For k = 1 To M
For i = k + 1 To M
For j = 1 To r
X(i, j) = X(i, j) - X(k, j) * lu(i, k)
Next j
Next i
Next k
'Solve U*X=Y
For k = M To 1 Step -1
For j = 1 To r
X(k, j) = X(k, j) / lu(k, k)
Next j
For i = 1 To k - 1
For j = 1 To r
X(i, j) = X(i, j) - X(k, j) * lu(i, k)
Next j
Next i
Next k
r_result.Resize(size, no_of_columns).Value = X
On Error GoTo 0
Exit Sub
Solve_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Solve of Class Module LuDecomposition"
End Sub
In the following, loop Cells() needs two arguments:
For f = 1 To Z
b(f) = Sheet4.Cells(f)
Next
There may be other problems.

Resources