có thể câu hỏi của em a(c) chưa rõ, ở đây là e tìm giá trị ở cột E, F, G dựa vào vị trí ở cột C
đối với các giá trị vừa tìm được có thể sẽ nằm chung 1 dòng.
ví dụ:
như bài #1 thì ở vị trí 0,00 (cột C) đầu tiên sẽ tìm ra 5 giá trị tương ứng (cột E, F, G) nhưng vì có thể một số giá trị nằm trùng nhau trên 1 dòng nên kết quả chỉ còn 4 dòng.
tương tự các vị trí phía dưới cũng vậy, tương ứng với từng vị trí sẽ tìm ra các giá trị như câu hỏi bài #1
về code của a :
thì kết quả của anh
View attachment 125485
còn kết quả của em:
View attachment 125486
vậy nhờ a sửa lại giúp em...e chân thành cảm ơn...
Thêm cái vụ cùng dòng có cả min cái này và max cái khác thì chỉ lấy 1 dòng, hic.
Thử chạy thử cái này coi sao, thấy nó lằng nhằng quá hổng biết trúng hông.
[GPECODE=vb]Public Sub MaxMin()
Dim Dic As Object, N As Long, M As Long, R As Long, Tem As String
Dim sArr(), dArr(), Arr(), I As Long, J As Long, K As Long, K2 As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("debai")
sArr = .Range(.[A14], .[H65536].End(xlUp)).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 9)
For N = 1 To UBound(sArr, 1) Step 9
K = K + 1
R = K
For I = N To N + 4
For J = 1 To 8
dArr(R, J) = sArr(I, J) 'Gan du lieu 5 dong dau tien
Next J
R = R + 1
Next I
R = K
For I = N To N + 8
If sArr(I, 5) < dArr(R, 5) Then
For J = 1 To 8
dArr(R, J) = sArr(I, J) ' MIN N
Next J
End If
If sArr(I, 6) < dArr(R + 1, 6) Then
For J = 1 To 8
dArr(R + 1, J) = sArr(I, J) 'MIN M2
Next J
End If
If sArr(I, 6) > dArr(R + 2, 6) Then
For J = 1 To 8
dArr(R + 2, J) = sArr(I, J) 'MAX M2
Next J
End If
If sArr(I, 7) < dArr(R + 3, 7) Then
For J = 1 To 8
dArr(R + 3, J) = sArr(I, J) 'MIN M3
Next J
End If
If sArr(I, 7) > dArr(R + 4, 7) Then
For J = 1 To 8
dArr(R + 4, J) = sArr(I, J) 'MAX M3
Next J
End If
Next I
K = K + 4
Next N
'---------------Xoa Trung dong
ReDim Arr(1 To K, 1 To 8)
For N = 1 To K Step 5
Dic.RemoveAll
For I = N To N + 4
Tem = dArr(I, 4)
If Not Dic.Exists(Tem) Then
K2 = K2 + 1
Dic.Add Tem, Empty
For J = 1 To 8
Arr(K2, J) = dArr(I, J)
Next J
End If
Next I
Next N
With Sheets("ketqua")
.[A14:H10000].ClearContents
.[A14].Resize(K2, 8) = Arr
End With
Set Dic = Nothing
End Sub
[/GPECODE]
