Chỉnh sửa code lọc mảng, tìm max theo điều kiện

[kokothay]

Mấy Anh chỉnh sửa tiếp em code lọc mảng, tìm max có điều kiện trong sheet Tong hop. Em chỉ biết mong các Anh chỉ thêm

 

[SA_DQ]

file của bạn hính như hư rồi & có thấy miếng Code nào đâu mà sửa;
Hay bạn chịu khó mô tả xem trong trang 'THop' đó bạn cần dữ liệu gì
Mà hình như loại bài này hàng năm đều có xuất hiện . . . .khoảng thu đông thì fải?
Áp dụng DMAX() đi bạn, với sự trợ giúp của macro.

 

[kokothay]

file còn macro mà bạn, mình mới kiểm lại đó

 

[♫ђöล♥ßล†♥†µ♫]

file còn macro mà bạn, mình mới kiểm lại đó

Bạn chạy thử Code này

Sub TongHopDuLieu()
    Dim Dic As Object, Dict As Object, sKey As String, R As Long, bh As String
    Dim tArr(), sArr(), dArr(), I As Long, K As Long, Er As Long
Set Dict = CreateObject("Scripting.Dictionary")
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Tinh thep Etabs")
    tArr = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, 11).Value
End With
For I = 1 To UBound(tArr)
    sKey = tArr(I, 2) & "#" & tArr(I, 4)
    Dict.Item(sKey) = I
Next I
With Sheets("So lieu Etabs")
    sArr = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, 10).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 8)
For I = 1 To UBound(sArr, 1)
    sKey = sArr(I, 2) & "#" & sArr(I, 4):    R = Dict.Item(sKey)
    If Not Dic.Exists(sKey) Then
        K = K + 1
        Dic.Add sKey, K
        dArr(K, 1) = sArr(I, 2):        dArr(K, 2) = sArr(I, 4)
        If R Then
            bh = UCase(Replace(tArr(R, 3), "D", ""))
            dArr(K, 3) = Split(bh, "X")(0) * 10:            dArr(K, 4) = Split(bh, "X")(1) * 10
            dArr(K, 5) = tArr(R, 8) * 1000000:            dArr(K, 6) = tArr(R, 11) * 1000000
        End If
        dArr(K, 7) = Abs(sArr(I, 6))
        dArr(K, 8) = Abs(sArr(I, 10))
    Else
        dArr(Dic.Item(sKey), 7) = IIf(dArr(Dic.Item(sKey), 7) >= Abs(sArr(I, 6)), dArr(Dic.Item(sKey), 7), Abs(sArr(I, 6)))
        dArr(Dic.Item(sKey), 8) = IIf(dArr(Dic.Item(sKey), 8) >= Abs(sArr(I, 10)), dArr(Dic.Item(sKey), 8), Abs(sArr(I, 10)))
    End If
Next I
With Sheets("Tong hop")
    Er = .Range("L" & Rows.Count).End(xlUp).Row
    If Er > 1 Then .Range("L2:L" & Er).Resize(, 8).ClearContents
    .Range("L2").Resize(K, 8) = dArr
End With
Set Dict = Nothing: Set Dic = Nothing
End Sub

 

[kokothay]

có đoạn đúng, đoạn sai Anh ơi

 

[♫ђöล♥ßล†♥†µ♫]

có đoạn đúng, đoạn sai Anh ơi

Sai thì phải sửa thôi . Nhưng Mình không hiểu cái bài toán này lắm. Bạn giải thích kỹ hơn 1 chút
Ví dụ lọc với tiêu chí cột gì gì và lấy cái gì gì kèm theo .......

 

[SA_DQ]

Mấy Anh chỉnh sửa tiếp em code lọc mảng, tìm max có điều kiện trong sheet Tong hop. Em chỉ biết mong các Anh chỉ thêm

Sau đây là macro tìm giá trị MAX tại cột [G] của trang 'Tong Hop' căn cứ vào danh sách duy nhất của cột 'A', mà danh sách duy nhất này đang có trên cột 'U';
Kết quả trả về tại các ô tương ứng trên cột 'V' liền kề

Option Explicit
Sub TimMAXCuaV2TheoBayID()
'Côt "U" Là Danh Sách Duy Nhât Cua Côt "A"     '
Dim Cls As Range, WF As Object:                                Dim Tmr As Double

Set WF = Application.WorksheetFunction:                        Tmr = Timer()
[AA1].Value = [A1].Value
For Each Cls In Range([U2], [U2].End(xlDown))
    [AA4].Value = Cls.Value   '**   '
    Cls.Offset(, 1).Value = WF.DMax([B2].CurrentRegion, [G1], [AA1:AA2])
Next Cls
[V1].Value = Timer() - Tmr
End Sub

Lưu ý: tại [AA2] ta áp công thức: ="="& AA4
Thời gian trên máy cà tèng của mình là .141"

 

[HieuCD]

Mấy Anh chỉnh sửa tiếp em code lọc mảng, tìm max có điều kiện trong sheet Tong hop. Em chỉ biết mong các Anh chỉ thêm

Code cho sheet Tong hop

Sub TongHopDuLieu()
  Dim Dic As Object, iKey As String
  Dim sArr(), Res(), i As Long, k As Long, ik As Long, j As Byte
  Set Dic = CreateObject("Scripting.Dictionary")
  With Sheets("Tinh thep Etabs")
    sArr = .Range("V2", .Range("AA" & Rows.Count).End(xlUp)).Value
  End With
  ReDim Res(1 To UBound(sArr), 1 To 8)
  For i = 1 To UBound(sArr)
    iKey = sArr(i, 1) & "#" & sArr(i, 2)
    If Not Dic.exists(iKey) Then
      k = k + 1
      For j = 1 To 6
        Res(k, j) = sArr(i, j)
      Next j
      Dic.Add iKey, k
    Else
      ik = Dic.Item(iKey)
      For j = 5 To 6
        If Res(ik, j) < sArr(i, j) Then Res(ik, j) = sArr(i, j)
      Next j
    End If
  Next i
 
  With Sheets("So lieu Etabs")
    sArr = .Range("M2", .Range("P" & Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(sArr, 1)
    ik = Dic.Item(sArr(i, 1) & "#" & sArr(i, 2))
    If ik > 0 Then
      For j = 7 To 8
        If Res(ik, j) < sArr(i, j - 4) Then Res(ik, j) = sArr(i, j - 4)
      Next j
    End If
  Next i
  With Sheets("Tong hop")
    i = .Range("L" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("A2:H" & i).ClearContents
    If k Then .Range("A2:H2").Resize(k) = Res
  End With
  Set Dic = Nothing
End Sub

 

[kokothay]

Code cho sheet Tong hop

Sub TongHopDuLieu()
  Dim Dic As Object, iKey As String
  Dim sArr(), Res(), i As Long, k As Long, ik As Long, j As Byte
  Set Dic = CreateObject("Scripting.Dictionary")
  With Sheets("Tinh thep Etabs")
    sArr = .Range("V2", .Range("AA" & Rows.Count).End(xlUp)).Value
  End With
  ReDim Res(1 To UBound(sArr), 1 To 8)
  For i = 1 To UBound(sArr)
    iKey = sArr(i, 1) & "#" & sArr(i, 2)
    If Not Dic.exists(iKey) Then
      k = k + 1
      For j = 1 To 6
        Res(k, j) = sArr(i, j)
      Next j
      Dic.Add iKey, k
    Else
      ik = Dic.Item(iKey)
      For j = 5 To 6
        If Res(ik, j) < sArr(i, j) Then Res(ik, j) = sArr(i, j)
      Next j
    End If
  Next i

  With Sheets("So lieu Etabs")
    sArr = .Range("M2", .Range("P" & Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(sArr, 1)
    ik = Dic.Item(sArr(i, 1) & "#" & sArr(i, 2))
    If ik > 0 Then
      For j = 7 To 8
        If Res(ik, j) < sArr(i, j - 4) Then Res(ik, j) = sArr(i, j - 4)
      Next j
    End If
  Next i
  With Sheets("Tong hop")
    i = .Range("L" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("A2:H" & i).ClearContents
    If k Then .Range("A2:H2").Resize(k) = Res
  End With
  Set Dic = Nothing
End Sub

Bài đã được tự động gộp: 8/11/18

Cảm ơn Anh rất nhiều !