Chào các bác,
E là thành viên mới, đang phải tự học VBA vì công việc có liên quan. Hôm nay e có 1 vấn đề liên quan đến ma trận, mảng mà chưa biết cách giải quyết, mong các bác giúp e. Thank in advance.
Đề bài 
hơi dài 1 chút, mong các bác cố gắng đọc, rất thú vị
)
Cho 1 dẫy số : 2,4,3,5,1,4,3,6,5,7,2,6,3,5,2,3,1,8,2,4,1,8,6
Yêu cầu :
Lập trình thuật toán (Tên tiếng anh là Rainflow) cho dẫy số trên. Tính chất thuật toán Rainflown :
- Xét 4 số đầu tiên trong 1 dẫy nếu thỏa mãn điều kiện :số thứ 2 và 3 nằm trong khoảng số thứ 1 và 4. thì lấy số thứ 2 và 3 ra khỏi dẫy(remove) ĐẾM vào 1 ma trận n*n (n là số lớn nhất trong dẫy, ở đây n=8). Sau khi số thứ 2 và thứ 3 bị lấy ra khỏi dẫy thì ta lại xét từ đầu 4 số đầu tiên, nếu thỏa mãn điều kiện (thì làm như trên), nếu không thỏa mãn điều kiện ta xét tiếp 4 số tiếp theo (số đầu tiên tính từ số thứ 2)
- ĐẾM cặp số thỏa mãn vào ma trận như thế nào? Số thứ 2 = vị trí hàng trong ma trận(row), số thứ 3= vị trí cột trong ma trận. Nếu có 1 cặp số thì vị trí đó đếm 1, nếu có 2 cặp số giống nhau thì vị trí đó đếm 2....
- Cuối cùng ta in ra dẫy số rút gọn(là dẫy số còn lại của dẫy trên sau khi các cặp số thỏa mãn bị remove)
Thuật toán trình bầy hơi dài và khó hiểu 1 chút. E xin được tính toán bằng tay với dẫy số trên cho các bác hiểu :
- Dấy số đã cho 2,4,3,5,1,4,3,6,5,7,2,6,3,5,2,3,1,8,2,4,1,8,6
- Xét 4 số đầu tiên :2,4,3,5 Ta thấy 4,3 thuộc khoảng 2,5. Vậy remove 4,3 cho vào ma trận 8*8 trong đó vị trí 4*3(hàng 4 cột 3) trong ma trận sẽ đếm giá trị là 1
- Sau khi 4,3 bị remove. Dẫy số sẽ là 2,5,1,4,3,6,5,7,2,6,3,5,2,3,1,8,2,4,1,8,6
- Xét 4 số đầu tiên 2,5,1,4 ta thấy ko thỏa mãn (5,1 không nằm trong 2,4)
- Lại xét tiếp 4 số tiếp theo(tính từ số thứ 2) là 5,1,4,3 ta thấy cũng không thỏa mãn
- Lại xét tiếp 4 số tiếp theo(tính từ số thứ 2 của dẫy trên) là 1,4,3,6 ta thấy thỏa mãn. Vậy cặp số 4,3 được đếm lần 2 trong ma trận 8*8 ở vị trí 4*3
- Dẫy số mới sẽ là 2,5,1,6,5,7,2,6,3,5,2,3,1,8,2,4,1,8,6
Cứ tiếp tục xét như vậy.....
Thuật toán trên e đã code được rồi, nhưng phần ĐẾM ma trận e chưa biết code. Mong các bác cao thủ giúp e, xin cám ơn nhiều. Dưới đây là đoạn code của e về thuật toán :
Sub Button1_Click()
' Creates Input and Output arrays
Dim InputArray As Variant
Dim OutputCollection As Variant
' Set input array
InputArray = CreateArrayFromRange("A2:A24")
' Calculates
Set OutputCollection = CalcAlgorithm(InputArray)
' Prints the result collection out into the shells
PrintCollection OutputCollection
End Sub
' Copies cells to an array
Function CreateArrayFromRange(yourRange As String) As Variant
Dim arrRng()
Dim Rng As range
x = 0
For Each Rng In range(yourRange)
ReDim Preserve arrRng(x)
arrRng(x) = Rng.Value
x = x + 1
Next Rng
CreateArrayFromRange = arrRng
End Function
' This function peforms the main algorithm.
Function CalcAlgorithm(InputArray As Variant) As Collection
' Result is an array that contains the matrix (2-dimensional array)
Dim Result As New Collection
' Checks whether the array's length satisfies the min. length
If UBound(InputArray) < LengthOfSegment Then
MsgBox "Cannot calculate!"
End If
' Copies the input array to a collection
Dim InputCollection As New Collection
Set InputCollection = CopyArrayToCollection(InputArray)
' BEGIN EXECUTE ALGORITHM
Dim CheckBegin, CheckEnd, CheckCount As Integer
CheckBegin = 1
CheckEnd = CheckBegin + 3
CheckCount = InputCollection.Count
Dim MatrixPointIndex As Integer
MatrixPointIndex = 0
Do While CheckEnd <= CheckCount
Dim LowerBound, UpperBound, CheckTarget1, CheckTarget2 As Double
LowerBound = InputCollection(CheckBegin)
UpperBound = InputCollection(CheckEnd)
CheckTarget1 = InputCollection(CheckBegin + 1)
CheckTarget2 = InputCollection(CheckBegin + 2)
Dim IsTarget1Satisfied, IsTarget2Satisfied As Boolean
IsTarget1Satisfied = Check(LowerBound, UpperBound, CheckTarget1)
IsTarget2Satisfied = Check(LowerBound, UpperBound, CheckTarget2)
Dim NewMatrixPoint As MatrixPoint
' If at least one targeted number is satified then reset the checking process (do at begin)
If IsTarget1Satisfied = True And IsTarget2Satisfied = True Then
' Adds a new matrix point to the result list
Set NewMatrixPoint = New MatrixPoint
NewMatrixPoint.DimensionX = CheckTarget1
NewMatrixPoint.DimensionY = CheckTarget2
MatrixPointIndex = MatrixPointIndex + 1
Result.Add NewMatrixPoint, CStr(MatrixPointIndex)
' Removes 2 targets out of the input collection
InputCollection.Remove (CheckBegin + 1)
InputCollection.Remove (CheckBegin + 1)
' Reset beginning check-position
CheckBegin = 1
Else
CheckBegin = CheckBegin + 1
End If
CheckEnd = CheckBegin + 3
CheckCount = InputCollection.Count
Loop
' END EXECUTE ALGORITHM
' Returns the calculated result
Set CalcAlgorithm = Result
End Function
' This function copies an array to a new collection
Function CopyArrayToCollection(InputArray As Variant) As Collection
Dim Output As New Collection
For i = 0 To UBound(InputArray)
Output.Add (InputArray(i))
Next i
Set CopyArrayToCollection = Output
End Function
' Checks whether the target number is in the given range (lowerbound <= x <= upperbound)
Function Check(ByVal LowerBound As Double, ByVal UpperBound As Double, ByVal Target As Double) As Boolean
If Target >= LowerBound And Target <= UpperBound Then
Check = True
ElseIf Target <= LowerBound And Target >= UpperBound Then
Check = True
Else
Check = False
End If
End Function
' Print a given collection to shells
Sub PrintCollection(ByRef InputCollection As Variant)
For Each Point In InputCollection
Debug.Print "(X = " + CStr(Point.DimensionX) + ", Y = " + CStr(Point.DimensionY) + ")"
MsgBox "(X = " + CStr(Point.DimensionX) + ", Y = " + CStr(Point.DimensionY) + ")"
' TODO the Count of Matrix????
Next Point
End Sub
-
InputArr(S3, 1) = ""
