Function Matrix(Rng As Range, ColTitle1 As Range, RwTitle1 As Range, ColTitle2 As Range, RwTitle2 As Range) As Variant
Dim TmpArr(), SArr()
SaR = RwTitle1.Count: SaC = ColTitle1.Count
ReDim SArr(1 To SaR, 1 To SaC)
TmpR = RwTitle2.Count: TmpC = ColTitle2.Count
ReDim TmpArr(1 To TmpR, 1 To TmpC)
SArr = Rng.Value
For i = 1 To TmpC
For j = 1 To TmpR
For k = 1 To SaC
For h = 1 To SaR
If RwTitle1(h, 1) = RwTitle2(j, 1) And ColTitle1(1, k) = ColTitle2(1, i) Then
TmpArr(j, i) = SArr(h, k): GoTo next2
End If
Next
Next
next2:
Next
Next
Matrix = TmpArr
End Function
Còn nếu như thứ tự đảo lộn hoặc bị xen kẽ?
Cái này đâu cần phải dùng vba
=IFERROR(HLOOKUP(H$11,$B$11:$F$15,MATCH($L12,$F$11:$F$15,0),0),0)Cám ơn Bác. Đúng là Em muốn viết hàm để xử lý trong trường hợp này để ứng dụng cho công việc
Có thể tối ưu hóa hàm trên không bác ?
Em cũng ngâm cứu xem thế nào. Cám ơn bác !
Function Matrix2(Rng As Range, ColTitle1 As Range, ColTitle2 As Range)
Dim TmpArr(), SArr(), RwTitle1, RwTitle2
SArrSize = ColTitle1.Count
ReDim SArr(1 To SArrSize, 1 To SArrSize)
TmpArrSize = ColTitle2.Count
ReDim TmpArr(1 To TmpArrSize, 1 To TmpArrSize)
SArr = Rng.Value
RwTitle1 = Application.Transpose(ColTitle1)
RwTitle2 = Application.Transpose(ColTitle2)
For i = 1 To TmpArrSize
For j = 1 To TmpArrSize
For k = 1 To SArrSize
If ColTitle1(1, k) = ColTitle2(1, i) Then
For h = 1 To SArrSize
If RwTitle1(h, 1) = RwTitle2(j, 1) Then
TmpArr(j, i) = SArr(h, k): Exit For
End If
Next
Exit For
End If
Next
Next
Next
Matrix2 = TmpArr
End FunctionQuả thực, em cam ơn bác ptm0412 nhiều nhiều ạ.
Call xoadong(A(), n, m, 3)
Call xoacot(A(), n, m, 4)
Call xuat2(A(), n, m)Call xoadong(A(), n, m, dong)
Call xoacot(A(), n, m, cot)
Call xuat2(A(), n, m)Sơn muốn gộp thành 1 hàm, hay muốn để riêng hàm trên, muốn cộng thì cộng, muốn trừ thì trừ, muốn nối chuỗi thì nối chuõi?
Em muốn phối hợp anh ạ; và thao tác trong 1 hàm luôn có được không ạ ? ( Nếu đã viết hàm thì mình có thể viết cho trường hộp gồm n ma trận cộng vào ko)
Đúng rồi ạ. Thực ra là hàm em muốn viết ý tưởng như sau:
Function SumMatrix(SourceRng As Range, SourceColTitle As Range, ColTitle2 As Range, ColTitle3 As Range)
Dim TmpArrB(), TmpArrC1(), TmpArrC2(), TmpArr(), SArray()
Dim SColT(), ColT2(), ColT3()
SArray = SourceRng.Value
SColT = SourceColTitle.Value
ColT2 = ColTitle2.Value
ColT3 = ColTitle3.Value
ArrSize = SourceColTitle.Count
ReDim TmpArr(1 To ArrSize, 1 To ArrSize)
TmpArrC1 = Matrix(SArray, SColT, ColT3)
TmpArrB = Matrix(SArray, SColT, ColT2)
TmpArrC2 = Matrix(TmpArrB, ColT2, ColT3)
For i = 1 To ArrSize
For j = 1 To ArrSize
TmpArr(i, j) = TmpArrC1(i, j) + TmpArrC2(i, j)
Next
Next
SumMatrix = TmpArr
End FunctionFunction Matrix(SArr, ColTitle1, ColTitle2)
Dim TmpArr(), RwTitle1, RwTitle2
SArrSize = UBound(SArr, 1)
ReDim TmpArr(1 To SArrSize, 1 To SArrSize)
RwTitle1 = Application.Transpose(ColTitle1)
RwTitle2 = Application.Transpose(ColTitle2)
For i = 1 To SArrSize
For j = 1 To SArrSize
For k = 1 To SArrSize
If ColTitle1(1, k) = ColTitle2(1, i) Then
For h = 1 To SArrSize
If RwTitle1(h, 1) = RwTitle2(j, 1) Then
TmpArr(j, i) = SArr(h, k): Exit For
End If
Next
Exit For
End If
Next
Next
Next
Matrix = TmpArr
End FunctionDạ, em cám ơn bác.
Dạ, em xin lỗi a. Vì em ngại viêt các số của B nên mới lấy như vậy.
Dạ không sao ạ.Vì lỗi này là do em ạ (Lần sau em sẽ chú ý khi yêu cầu
- thực ra nhầm quan điểm chút thôi ạ). Cám ơn thầy đã giúp đỡ. Em cám ơn rất nhiều !
Function SumMatrix(SRng1 As Range, SColTitle1 As Range, SRng2 As Range, SColTitle2 As Range, RColTitle As Range)
'SRng = Source Range, SColTitle = Source Column Titlles'
'RColTitle = Result Column Titles'
Dim TmpArrC1(), TmpArrC2(), TmpArr(), SArray1(), SArray2()
Dim SColT1(), SColT2(), RColT()
SArray1 = SRng1.Value
SArray2 = SRng2.Value
SColT1 = SColTitle1.Value
SColT2 = SColTitle2.Value
RColT = RColTitle.Value
ArrSize = SColTitle1.Count
ReDim TmpArr(1 To ArrSize, 1 To ArrSize)
TmpArrC1 = Matrix(SArray1, SColT1, RColT)
TmpArrC2 = Matrix(SArray2, SColT2, RColT)
For i = 1 To ArrSize
For j = 1 To ArrSize
If (IsNumeric(TmpArrC1(i, j)) And IsNumeric(TmpArrC2(i, j))) Then
TmpArr(i, j) = Val(TmpArrC1(i, j)) + Val(TmpArrC2(i, j))
Else
TmpArr(i, j) = TmpArrC1(i, j) & TmpArrC2(i, j)
End If
Next
Next
SumMatrix = TmpArr
End FunctionKhi em check mà trùng Title vẫn thấy kết quả đúng ?
Public Function Matran(E As Double, A As Double, J As Double, l As Double)
Dim MT(1 To 6, 1 To 6)
Dim t1, t2, t3, t4, t5 As Double
t1 = E * A / l: t2 = 12 * E * J / (l ^ 3): t3 = 6 * E * J / (l ^ 2): t4 = 4 * E * J / l: t5 = 2 * E * J / l
MT(1, 1) = t1: MT(1, 2) = 0: MT(1, 3) = 0: MT(1, 4) = -t1: MT(1, 5) = 0: MT(1, 6) = 0
MT(2, 1) = 0: MT(2, 2) = t2: MT(2, 3) = t3: MT(2, 4) = 0: MT(2, 5) = -t2: MT(2, 6) = t3
MT(3, 1) = 0: MT(3, 2) = t3: MT(3, 3) = t4: MT(3, 4) = 0: MT(3, 5) = -t3: MT(3, 6) = t5
MT(4, 1) = -t1: MT(4, 2) = 0: MT(4, 3) = 0: MT(4, 4) = t1: MT(4, 5) = 0: MT(4, 6) = 0
MT(5, 1) = 0: MT(5, 2) = -t2: MT(5, 3) = -t3: MT(5, 4) = 0: MT(5, 5) = t2: MT(5, 6) = -t3
MT(6, 1) = 0: MT(6, 2) = t3: MT(6, 3) = t5: MT(6, 4) = 0: MT(6, 5) = -t3: MT(6, 6) = t4
Matran = MT
End Function
Thì viết thêm 1 sub nữa
Sub Test()
Dim E As Double, A As Double, J As Double, l As Double
E = bao nhiêu?
A = bao nhiêu?
J = bao nhiêu?
l = bao nhiêu?
ActiveCell.Resize(6, 6).Value = Matran(E, A, J, l)
End SubCái này mà dùng INDEX thì.. hơi phí sư phụ à
Thế bạn có ý tưởng gì khác chăng? Hoặc giả ý bạn mong muốn nó phải như thế nào?
Đúng là em đang thao tác hàm trên như đúng ý bác nói.
Dùng sự kiện WorksheetChange xem!
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ExitSub
If Left(Target.Formula, 7) = "=Matran" Then Target.Resize(6, 6).FormulaArray = Target.Formula
ExitSub:
End SubDòng dứơi là e viết:"+ Có thể bẫy lỗi như sau không ạ: Khi mình quét chọn không đủ 6 hàng , 6 cột sẽ đưa ra thông báo lỗi" với mục đích là nếu không xử lý được như yêu cầu trên thì mình dùng cách chọn 6 hàng, 6 cột, nếu không được mới thông báo lỗi.
' Ham danh so Thu tu
Public Function Vecto(SoAn As Integer)
Dim A(), n
n = SoAn
ReDim A(1 To n)
For i = 1 To n
A(i) = i
Next i
Vecto = A
Call Macro1
End Function
' Thu tuc dinh dang so
Sub Macro1()
Selection.NumberFormat = """(""#0"")"""
End SubBạn có 2 cách để lựa chọn:
Public Function MTDX(Matrakiemtra As Range)
Dim m, n, i, j As Integer
m = Matrakiemtra.Rows.Count
n = Matrakiemtra.Columns.Count
For i = 1 To m
For j = 1 To n
If Matrakiemtra(i, j) = Matrakiemtra(j, i) Then
MsgBox "Ma tran doi xung qua duong cheo chinh", vbCritical, "Nguyen Ngoc Son"
Else
MsgBox "Ma tran khong doi xung qua duong cheo chinh", vbCritical, "Nguyen Ngoc Son"
End If
Next j
Next i
End FunctionPublic Function MTDX(Matran As Range) As Boolean
Dim m, n, i, j As Integer
MTDX = True
m = Matran.Rows.Count
n = Matran.Columns.Count
For i = 1 To m
For j = 1 To n
If Matran(i, j) <> Matran(j, i) Then
MTDX = False
Exit Function
End If
Next j
Next i
End Function
hơi dài 1 chút, mong các bác cố gắng đọc, rất thú vị 
) 
Tôi làm mới hoàn toàn chứ không làm theo code của bạn. Test code bằng file đính kèm.Chào các bác,
Đề bài
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)
Sub GPE()
ActiveSheet.UsedRange.Offset(, 1).ClearContents
Dim InputArr, Result(), S1 As Long, S2 As Long, S3 As Long, S4 As Long, n As Long
InputArr = Range([A2], [A65536].End(xlUp)).Value
n = Application.WorksheetFunction.Max(Range([A2], [A65536].End(xlUp)))
ReDim Result(1 To n, 1 To n)
S1 = 1: S2 = 2: S3 = 3: S4 = 4
Do
If (InputArr(S2, 1) >= InputArr(S1, 1)) And (InputArr(S3, 1) >= InputArr(S1, 1)) And (InputArr(S2, 1) <= InputArr(S4, 1)) And (InputArr(S3, 1) <= InputArr(S4, 1)) Then
Result(InputArr(S2, 1), InputArr(S3, 1)) = Result(InputArr(S2, 1), InputArr(S3, 1)) + 1
InputArr(S2, 1) = "": InputArr(S3, 1) = ""
S2 = S2 + 2: S3 = S3 + 2: S4 = S4 + 2
Else
S4 = S4 + 1: S3 = S4 - 1: S2 = S3 - 1: S1 = S2 - 1
End If
Loop Until S4 > UBound(InputArr, 1)
[D2].Resize(n, n).Value = Result
With Application.WorksheetFunction
InputArr = .Transpose(Split(.Trim(Join(.Transpose(InputArr)))))
End With
[B2].Resize(UBound(InputArr, 1)).Value = InputArr
End Sub
InputArr(S3, 1) = "" InputArr(S3, 1) = ""
Bạn trình bày lại cách bạn thực hiện thủ công xem từng bước xem như thế nào chứ theo những gì bạn mô tả tôi không làm ra kết quả như bạn được.Cám ơn bác huuthang_bd!
Phần code của bác có 1 chỗ chưa đúng ở chỗ điều kiện(IF) cho các S1, S2, S3, S4. Em đã sửa và thêm vào điều kiện Elseif nhưng cũng không ra đúng kết quả. Em cũng ko biết tại sao.
Theo tính toán bằng tay của em, với dẫy số trên thì kết quả phải trả về lần lượt
Sub GPE()
ActiveSheet.UsedRange.Offset(, 1).ClearContents
Dim InArr, MyArr(), Result(), s As Long, n As Long, i As Long
InArr = Range([A2], [A65536].End(xlUp)).Value
n = Application.WorksheetFunction.Max(Range([A2], [A65536].End(xlUp)))
ReDim Result(1 To n, 1 To n)
s = 1
Do
If (InArr(s + 1, 1) >= InArr(s, 1)) And (InArr(s + 2, 1) >= InArr(s, 1)) And (InArr(s + 1, 1) <= InArr(s + 3, 1)) And (InArr(s + 2, 1) <= InArr(s + 3, 1)) Or (InArr(s + 1, 1) < InArr(s, 1)) And (InArr(s + 2, 1) < InArr(s, 1)) And (InArr(s + 1, 1) > InArr(s + 3, 1)) And (InArr(s + 2, 1) > InArr(s + 3, 1)) Then
Result(InArr(s + 1, 1), InArr(s + 2, 1)) = Result(InArr(s + 1, 1), InArr(s + 2, 1)) + 1
ReDim MyArr(1 To UBound(InArr, 1) - 2, 1 To 1)
For i = 1 To s
MyArr(i, 1) = InArr(i, 1)
Next
For i = s + 3 To UBound(InArr, 1)
MyArr(i - 2, 1) = InArr(i, 1)
Next
InArr = MyArr
Erase MyArr
s = 1
Else
s = s + 1
End If
Loop Until s + 3 > UBound(InArr, 1)
[D2].Resize(n, n).Value = Result
[B2].Resize(UBound(InArr, 1)).Value = InArr
End Sub
Public Sub Ma()
Dim Vung, I, J, K, Tam(1 To 4), Wf, Mg(), M
Set Wf = Application.WorksheetFunction
Vung = Range([a2], [a100].End(xlUp)).Value
ReDim Mg(1 To Wf.Max(Vung), 1 To Wf.Max(Vung))
For I = 1 To UBound(Vung) - 4
If I = K - 3 Then Exit Sub
For J = 1 To 4
Tam(J) = Vung(I + J - 1, 1)
Next J
If Tam(1) = Wf.Min(Tam) And Tam(4) = Wf.Max(Tam) Or Tam(1) = Wf.Max(Tam) And Tam(4) = Wf.Min(Tam) Then
Mg(Tam(2), Tam(3)) = Mg(Tam(2), Tam(3)) + 1
Vung(I + 1, 1) = "": Vung(I + 2, 1) = "": K = 0: [b2:b23].ClearContents
For J = 1 To UBound(Vung) - M
If Vung(J, 1) <> "" Then
K = K + 1
Vung(K, 1) = Vung(J, 1)
End If
Next J
I = 1: M = M + 2
[b2].Resize(K) = Vung
[c3].Resize(Wf.Max(Vung), Wf.Max(Vung)) = Mg
End If
Next I
End SubĐây là một trong các cách:
Sub Test()
Dim Vung As Range, n As Long
n = 61
Set Vung = Range("A" & n - 60 & ":B" & n)
MsgBox Vung.Address
End Sub
