Ghi(record) vào ma trận trong VBA (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

bochumer

Thành viên mới
Tham gia
10/5/11
Bài viết
9
Được thích
0
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 :
Cho 8 cặp số : (4,3) (4,3) (6,5) (3,5) (2,3) (2,4) (1,8) (6,7)

Yêu cầu :
Ghi(record) các cặp số trên vào ma trận 8*8 sao cho
- Số đầu tiên = vị trí hàng trong ma trận(row), số thứ 2= 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....
- Ví dụ ở trên có 2 cặp số (4,3) thì trong ma trận 8*8 vị trí 4*3(hàng 4 cột 3) sẽ ghi lại là 2

Mong các bác cao thủ giúp e, xin cám ơn nhiều.
 
Dữ liệu đầu vào được lấy từ đâu? Sau khi tạo mảng xong thì làm gì nữa, đưa kết quả đi đâu? Tốt nhất là bạn đưa file lên.
 
Upvote 0
Chào bác,
Không hiếu sao e ko tải được file đính kèm lên :((
Thật ra phần e hỏi chỉ là 1 phần nhỏ trong thuật toán e cần phải code trong VBA. E sẽ nêu cụ thể ở đây có j bác xem rồi góp ý cho e nhé.

Đề bài :(hơi dài 1 chút, mong 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 xét lại từ đầu 4 số đầu tiên của dãy số mới đã bị rút gọ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 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) và ma trận ra exel

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 IN các cặp số vào trong ma trận và dẫy số rút gọ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) + ")"

Next Point
End Sub
 
Upvote 0
Không hiểu được nội dung của macro. Lười thôi :))

Nhưng xin giử bạn, có thể dùng tham khảo:

Cells(1,3)="nội dung gì đó"

để nhập vào ô trên hàng 1, cột 3 giá trị là "nội dung gì đó"
Chú ý: Nếu "nội dung gì đó" là giá trị số thì không cần dấu nháy kép
Và có thể là 1 công thức (hoặc 1 tên biến).

số 1 , 3 cũng có thể là công thức hoặc biến (cái này không tự tin lắm, bạn dùng thì thử lại)
 
Upvote 0
Nhờ Mod xóa giùm topic này. Nó đã có và đã được trả lời ở đây.
 
Upvote 0
Web KT

Bài viết mới nhất

Back
Top Bottom