Tối ưu code vba lọc dữ liệu

[nguyenkhoadng]

Chào các anh!

Hôm trước e có lập 1 topic nhờ giúp 1 đoạn code lọc dữ liệu, và được sự giúp đỡ của các a trên GPE + copy mấy code được chia sẻ trên mạng, giờ e được 1 đoạn code lọc dữ liệu cho bảng tính thép dầm như trong file đính kèm.
(Nội dung đoạn code này: sẽ IN NGHIÊNG các dầm có nội lực thỏa điều kiện, và sau đó xóa các dòng ko có in nghiêng, giữ lại các dòng in nghiêng)

Nhưng với đoạn code này thì nếu trong bảng có nhiều dầm, nhiều tầng thì quá trình lọc sẽ rất lâu (lâu nhất là quá trình delete).
Nay nhờ các a tối ưu giúp e đoạn code để quá trình lọc được nhanh hơn.

e cảm ơn trước!

 

[HieuCD]

em chào anh ạ
nhờ anh giúp đỡ code này em với ạ
- Qui tắc lọc:
dựa vào phần tử &tên dầm để lọc
Cùng 1 phần tử$tên dầm thì giữ lại giá trị M3 lớn nhất và M3 bé nhất(cột I)
em đã viết được phần M3 lớn nhất
còn phần M3 bé nhất đang chưa đúng
Nhờ anh xem lại đoạn code giúp em với ạ
em cảm ơn anh

Giải thích của bạn trong file khó hiểu quá
Thử code

Sub LocDam()
  Dim Dic As Object, sArr(), Res(), iKey$, iM3#
  Dim i&, j&, k&, ik&, sRow&, sCol&

  Set Dic = CreateObject("Scripting.Dictionary")
  With Sheets("data")
    sArr = .Range("A15:Q" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow, 1 To sCol)
  k = -1
  For i = 1 To sRow
    If sArr(i, 1) <> Empty Then
      iKey = sArr(i, 1) & sArr(i, 2)
      iM3 = sArr(i, 9)
      If Not Dic.Exists(iKey) Then
        k = k + 2
        Dic.Add iKey, k
        Res(k, 1) = i: Res(k, 2) = iM3
        Res(k + 1, 1) = i: Res(k + 1, 2) = iM3
      Else
        ik = Dic.Item(iKey)
        If Res(ik, 2) > iM3 Then 'Xet Nho nhat
          Res(ik, 1) = i: Res(ik, 2) = iM3
        End If
        If Res(ik + 1, 2) < iM3 Then 'Xet Lon nhat
          Res(ik + 1, 1) = i: Res(ik + 1, 2) = iM3
        End If
      End If
    End If
  Next i
  For i = 1 To k + 1
    ik = Res(i, 1)
    For j = 1 To sCol
      Res(i, j) = sArr(ik, j)
    Next j
  Next i
'---------------------------------------
  With Sheets("Beams")
    .Range("A15:Q65000").ClearContents
    If k > 0 Then .Range("A15:Q15").Resize(k + 1).Value = Res
  End With
  Set Dic = Nothing
End Sub

 

[Ba Tê]

em chào anh ạ
nhờ anh giúp đỡ code này em với ạ
- Qui tắc lọc:
dựa vào phần tử &tên dầm để lọc
Cùng 1 phần tử$tên dầm thì giữ lại giá trị M3 lớn nhất và M3 bé nhất(cột I)
em đã viết được phần M3 lớn nhất
còn phần M3 bé nhất đang chưa đúng
Nhờ anh xem lại đoạn code giúp em với ạ
em cảm ơn anh

Tự nhiên "đào mả" 6 năm trước, chẳng giải thích lấy dữ liệu từ sheet nào, gán vào sheet nào.
Đưa cái file có Code viết sẵn chẳng hiểu sao ra sao.
Bạn xem file này, lọc dữ liệu từ sheet "Data", theo điều kiện của bạn, ghi sang sheet "GPE".
Không đúng thì tính sau.

 

[authority]

Tự nhiên "đào mả" 6 năm trước, chẳng giải thích lấy dữ liệu từ sheet nào, gán vào sheet nào.
Đưa cái file có Code viết sẵn chẳng hiểu sao ra sao.
Bạn xem file này, lọc dữ liệu từ sheet "Data", theo điều kiện của bạn, ghi sang sheet "GPE".
Không đúng thì tính sau.

Dạ đúng ý của em rồi anh à
Em cảm ơn anh

Bài đã được tự động gộp: 4/3/20

Giải thích của bạn trong file khó hiểu quá
Thử code

Sub LocDam()
  Dim Dic As Object, sArr(), Res(), iKey$, iM3#
  Dim i&, j&, k&, ik&, sRow&, sCol&

  Set Dic = CreateObject("Scripting.Dictionary")
  With Sheets("data")
    sArr = .Range("A15:Q" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow, 1 To sCol)
  k = -1
  For i = 1 To sRow
    If sArr(i, 1) <> Empty Then
      iKey = sArr(i, 1) & sArr(i, 2)
      iM3 = sArr(i, 9)
      If Not Dic.Exists(iKey) Then
        k = k + 2
        Dic.Add iKey, k
        Res(k, 1) = i: Res(k, 2) = iM3
        Res(k + 1, 1) = i: Res(k + 1, 2) = iM3
      Else
        ik = Dic.Item(iKey)
        If Res(ik, 2) > iM3 Then 'Xet Nho nhat
          Res(ik, 1) = i: Res(ik, 2) = iM3
        End If
        If Res(ik + 1, 2) < iM3 Then 'Xet Lon nhat
          Res(ik + 1, 1) = i: Res(ik + 1, 2) = iM3
        End If
      End If
    End If
  Next i
  For i = 1 To k + 1
    ik = Res(i, 1)
    For j = 1 To sCol
      Res(i, j) = sArr(ik, j)
    Next j
  Next i
'---------------------------------------
  With Sheets("Beams")
    .Range("A15:Q65000").ClearContents
    If k > 0 Then .Range("A15:Q15").Resize(k + 1).Value = Res
  End With
  Set Dic = Nothing
End Sub

dạ đúng rồi anh à
em cảm ơn anh nhiều