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

nguyenkhoadng · 17/7/14

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!

hungpecc1 · 17/7/14

nguyenkhoadng đã viết:
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!

chưa bàn về vấn đề giải thuật, nội dung code,
Khi làm việc với dữ liệu lớn, trực tiếp trong bảng tính , nên bổ sung một số câu lệnh tắt chế độ màn hình để tăng tốc độ code, tham khảo link sau :
http://www.giaiphapexcel.com/forum/showthread.php?21361-Tăng-tốc-cho-code-VBA-của-bạn
hoặc xem cuốn "VBA trong Excel - Cải thiện và tăng tốc " của tác giả Kyo

nguyenkhoadng · 17/7/14

Cảm ơn a! e có thử với đoạn speedOn/Off nhưng với bảng tính nhiều công thức và nhiều dầm quá thì file excel của e bị đơ luôn

Chắc vụ này phải nhờ các a can thiệp vào code giúp e.

hungpecc1 · 17/7/14

nguyenkhoadng đã viết:
Cảm ơn a! e có thử với đoạn speedOn/Off nhưng với bảng tính nhiều công thức và nhiều dầm quá thì file excel của e bị đơ luôn
Chắc vụ này phải nhờ các a can thiệp vào code giúp e.

khuya rồi ngại xem code lắm , bạn thử miêu tả qua mục đích nội dung bạn cần là gì ?
In nghiêng các dầm có nội lực thỏa điều kiện : vậy điều kiện ở đây là gì ??

VetMini · 18/7/14

Dữ liệu nhiều (lời của bạn) mà dùng chế độ "In nghiêng" để phân biệt thì tìm chúng có mà lỏ con mắt.
Khi một bảng có nhiều dữ liệu, cách phân biệt hữu hiệu nhất là đặt thêm cột phụ để đánh dấu hoặc lọc chúng sang bảng phụ.

nguyenkhoadng · 18/7/14

Cảm ơn a!

mục đích e cần là:
1. Chọn ở đầu dầm có giá trị Mmin (giá trị âm) lớn nhất và tô đậm ở cột D (Ví dụ ở dầm B1 tại vị trí đầu dầm 0.11 có Mmin là -31.07 và tô đậm ô D12)
2. Chọn ở tất cả các vị trí trên dầm lấy giá trị Mmax (giá trị dương) lớn nhất (Ví dụ ở dầm B1 tại tất cả các vị trí ta chọn được Mmax là 26.00 và tô đậm ô D13)
3. Chọn ở cuối dầm có giá trị Mmin (giá trị âm) lớn nhất (Ví dụ ở dầm B1 tại vị trí cuối dầm 2.80 có Mmin là -29.48 và tô đậm ô D28)

Tiếp theo đó là 1 code xoá tất cả các dòng không thoả điều kiện.

e cảm ơn!

hungpecc1 · 18/7/14

nguyenkhoadng đã viết:
Cảm ơn a!

mục đích e cần là:
1. Chọn ở đầu dầm có giá trị Mmin (giá trị âm) lớn nhất và tô đậm ở cột D (Ví dụ ở dầm B1 tại vị trí đầu dầm 0.11 có Mmin là -31.07 và tô đậm ô D12)
2. Chọn ở tất cả các vị trí trên dầm lấy giá trị Mmax (giá trị dương) lớn nhất (Ví dụ ở dầm B1 tại tất cả các vị trí ta chọn được Mmax là 26.00 và tô đậm ô D13)
3. Chọn ở cuối dầm có giá trị Mmin (giá trị âm) lớn nhất (Ví dụ ở dầm B1 tại vị trí cuối dầm 2.80 có Mmin là -29.48 và tô đậm ô D28)

Tiếp theo đó là 1 code xoá tất cả các dòng không thoả điều kiện.

e cảm ơn!

Dầm B1 story 1 có khác dầm B1 story 2 không ? hay là chỉ lọc theo tiêu chí tên của dầm !

nguyenkhoadng · 18/7/14

hungpecc1 đã viết:
Dầm B1 story 1 có khác dầm B1 story 2 không ? hay là chỉ lọc theo tiêu chí tên của dầm !

story 1, story 2, story 3,... là các tầng khác nhau. lọc ở đây là các dầm thoả điều kiện trong mỗi tầng.
Nên B1 story 1 khác B1 story 2 a ah.

hungpecc1 · 18/7/14

nguyenkhoadng đã viết:
story 1, story 2, story 3,... là các tầng khác nhau. lọc ở đây là các dầm thoả điều kiện trong mỗi tầng.
Nên B1 story 1 khác B1 story 2 a ah.

ok đã hiểu vấn đề, khoảng cuối giờ chiều, mình sẽ thử viết một đoạn code cho bạn !

hungpecc1 · 18/7/14

nguyenkhoadng đã viết:
story 1, story 2, story 3,... là các tầng khác nhau. lọc ở đây là các dầm thoả điều kiện trong mỗi tầng.
Nên B1 story 1 khác B1 story 2 a ah.

Với dữ liệu bạn gửi lên ,mình thấy:
* Mỗi 1 dầm luôn luôn có số lượng vị trí > 3
* Và giá trị tương tứng ở từng vị trí được sắp xếp từ bé đến lớn!
Với điều kiện trên mình thử viết code như sau :

Mã:

Sub GPE()
'Arr la mang ket qua : trong do Arr(i,1) = dia chi dong
'                               Arr(i,2) = Chieu dai
'                               Arr(i,3) = M min
'                               Arr(i,4) = M average
'                               Arr(i,5) = M Max
'                               Arr(i,6) = iR
'                               Arr(i,7) = tmpM
    Dim tmpArr, tmp, Arr(), ArrIndex(1 To 3), ArrLength(1 To 3)
    Dim i&, j&, index, str$
        tmpArr = Range("A11", [F65536].End(3))
        ReDim Arr(1 To UBound(tmpArr, 1), 1 To 7)
'________________________________________________________________
        With CreateObject("scripting.dictionary")
            For i = 1 To UBound(tmpArr, 1)
                tmp = CStr(Trim(tmpArr(i, 1))) & CStr(Trim(tmpArr(i, 2)))
                If Len(tmp) Then
                    If Not .exists(tmp) Then
                        n = n + 1:   .Add tmp, n
                        ArrIndex(1) = i:                        ArrIndex(2) = i:                        ArrIndex(3) = i
                        ArrLength(1) = CDbl(tmpArr(i, 3)):      ArrLength(2) = CDbl(tmpArr(i, 3)):      ArrLength(3) = CDbl(tmpArr(i, 3))
                        Arr(n, 1) = ArrIndex:                   Arr(n, 2) = ArrLength
                        Arr(n, 3) = CDbl(tmpArr(i, 6)):         Arr(n, 4) = 0:                          Arr(n, 5) = CDbl(tmpArr(i, 6))
                        Arr(n, 6) = 1
                    Else
                        j = .Item(tmp)
                        'If Arr(j, 6) = 2 Then Arr(j, 7) = i:        Arr(j, 8) = CDbl(tmpArr(i, 6))
                        Select Case tmpArr(i, 3)
                            Case Is < Arr(j, 2)(1)
                                    Arr(j, 1)(1) = i:               Arr(j, 2)(1) = CDbl(tmpArr(i, 3)):          Arr(j, 3) = CDbl(tmpArr(i, 6))
                            Case Is = Arr(j, 2)(1)
                                    If tmpArr(i, 6) < Arr(j, 3) Then
                                        Arr(j, 1)(1) = i:           Arr(j, 2)(1) = CDbl(tmpArr(i, 3)):          Arr(j, 3) = CDbl(tmpArr(i, 6))
                                    End If
                            '............................................................................................................
                            Case Is > Arr(j, 2)(3)
                                    Arr(j, 1)(3) = i:               Arr(j, 2)(3) = CDbl(tmpArr(i, 3)):          Arr(j, 5) = CDbl(tmpArr(i, 6))
                                    If Arr(j, 7) > Arr(j, 4) Then
                                        Arr(j, 4) = Arr(j, 7): Arr(j, 1)(2) = Arr(j, 6)
                                    End If
                                    Arr(j, 6) = i:              Arr(j, 7) = CDbl(tmpArr(i, 6))
                            Case Is = Arr(j, 2)(3)
                                    If tmpArr(i, 6) > Arr(j, 5) Then
                                        Arr(j, 1)(3) = i:           Arr(j, 2)(3) = CDbl(tmpArr(i, 3)):          Arr(j, 5) = CDbl(tmpArr(i, 6))
                                        Arr(j, 6) = i:              Arr(j, 7) = CDbl(tmpArr(i, 6))
                                    End If
                        End Select
                    End If
                End If
            Next
        End With
'_________________________________________________________________________________________________________
        If n Then
            Cells.Interior.Color = xlNone
            ReDim tmpArr(1 To UBound(tmpArr, 1))
            For i = 1 To n
                For Each index In Arr(i, 1)
                    tmpArr(index) = True
                    j = 10 + index: Range("A" & j).Resize(, 29).Interior.Color = vbYellow
                Next
            Next
            If MsgBox("Xoa du lieu khong thoa man", vbOKCancel) = vbOK Then
                Application.ScreenUpdating = False
                ReDim Arr(1 To UBound(tmpArr), 1 To 26)
                Cells.Interior.Color = xlNone
                For i = 1 To UBound(tmpArr)
                    If Not tmpArr(i) Then
                        j = i + 10
                        Rows(j & ":" & j).Delete
                    End If
                Next
            End If
        End If
        Application.ScreenUpdating = True
End Sub

bạn kiểm tra thử xem kết quả thế nào !

nguyenkhoadng · 18/7/14

Cảm ơn a đã giúp e đoạn code!

e đã test thử và có chút vấn đề nhờ a giúp:
1. e muốn chọn ra giá trị Mmin lớn nhất (đầu dầm), giá trị Mmax lớn nhất (cả dầm), giá trị Mmin lớn nhất (cuối dầm)
---> với đoạn code a giúp thì chọn giá trị Mmin lớn nhất (đầu dầm),giá trị Mmax lớn nhất (từ những vị trí nằm giữa 2 điểm đầu và cuối), giá trị Mmax lớn nhất (cuối dầm).
2. Phần code xóa các dòng gặp chút vấn đề là xóa không hết a ah.

Nhờ a giúp, e cảm ơn!

Ba Tê · 18/7/14

nguyenkhoadng đã viết:
story 1, story 2, story 3,... là các tầng khác nhau. lọc ở đây là các dầm thoả điều kiện trong mỗi tầng.
Nên B1 story 1 khác B1 story 2 a ah.

Thử file này, sheet GPE, xem kết quả có giống với kết quả mẫu không?
Oái! File gì nặng thế!

hungpecc1 · 18/7/14

nguyenkhoadng đã viết:
Cảm ơn a đã giúp e đoạn code!

e đã test thử và có chút vấn đề nhờ a giúp:
1. e muốn chọn ra giá trị Mmin lớn nhất (đầu dầm), giá trị Mmax lớn nhất (cả dầm), giá trị Mmin lớn nhất (cuối dầm)
---> với đoạn code a giúp thì chọn giá trị Mmin lớn nhất (đầu dầm),giá trị Mmax lớn nhất (từ những vị trí nằm giữa 2 điểm đầu và cuối), giá trị Mmax lớn nhất (cuối dầm).
2. Phần code xóa các dòng gặp chút vấn đề là xóa không hết a ah.

Nhờ a giúp, e cảm ơn!

Theo mình hiểu thì : M là giá trị momen và quy ước momen dương ở dưới , mômen âm ở trên
Với cách chọn tổ hợp của bạn thì mình đoán bạn sẽ sử dụng Mmax để tính toán cho toàn bộ côt thép đặt ở bên dưới, và Mmin cho toàn bộ cốt thép ở trên. Theo cách này vì việc tính toán , bố trí thép đơn giản ,nhưng sẽ gây lãng phí với những dầm có chiều dài lớn!
Hiện nay Cách chọn tổ hợp nội lực của bạn chỉ phù hợp với tính toán dầm của các bản sàn , không phù hợp để tính dầm của các khung nhà !
* Code của anh Bate ở bài dưới chọn đúng cặp tổ hợp của bạn mong muốn , bạn có thể tham khảo và tùy biến !

nguyenkhoadng · 18/7/14

Ba Tê đã viết:
Thử file này, sheet GPE, xem kết quả có giống với kết quả mẫu không?
Oái! File gì nặng thế!

Cảm ơn a!
Kết quả đúng với ý e rồi.
a có thể giúp e lọc ngay tại sheet "TinhThep" được không a? và cứ mỗi 3 dòng Mmin, Mmax, Mmin thì tự động kẽ 1 dòng nét đứt phân chia ra cho dễ quan sát (giống file mẫu).

e cảm ơn!

nguyenkhoadng · 18/7/14

hungpecc1 đã viết:
Theo mình hiểu thì : M là giá trị momen và quy ước momen dương ở dưới , mômen âm ở trên
Với cách chọn tổ hợp của bạn thì mình đoán bạn sẽ sử dụng Mmax để tính toán cho toàn bộ côt thép đặt ở bên dưới, và Mmin cho toàn bộ cốt thép ở trên. Theo cách này vì việc tính toán , bố trí thép đơn giản ,nhưng sẽ gây lãng phí với những dầm có chiều dài lớn!
Hiện nay Cách chọn tổ hợp nội lực của bạn chỉ phù hợp với tính toán dầm của các bản sàn , không phù hợp để tính dầm của các khung nhà !
* Code của anh Bate ở bài dưới chọn đúng cặp tổ hợp của bạn mong muốn , bạn có thể tham khảo và tùy biến !

Cảm ơn a!

Nghe a nói có chắc a cũng là dân xây dựng. cách sử dụng các cặp nội lực để tính e dựa vào sách của tác giả Lê Bá Huế.
Cũng chưa có nhiều kinh nghiệm thiết kế nên có gì mong các a chỉ giúp.
e cảm ơn!

vuivui85 · 18/7/14

nguyenkhoadng đã viết:
Cảm ơn a!
Kết quả đúng với ý e rồi.
a có thể giúp e lọc ngay tại sheet "TinhThep" được không a? và cứ mỗi 3 dòng Mmin, Mmax, Mmin thì tự động kẽ 1 dòng nét đứt phân chia ra cho dễ quan sát (giống file mẫu).

e cảm ơn!

Mã:

ReDim dArr(1 To K * 3, 1 To Col)
K2 = -2
For N = 1 To K
    Dau = Cuoi + 1
    Cuoi = Cuoi + tArr(N, 2)
    K2 = K2 + 3
        For J = 1 To Col
            dArr(K2, J) = sArr(Dau + 1, J)
            dArr(K2 + 1, J) = sArr(Dau, J)
            dArr(K2 + 2, J) = sArr(Cuoi, J)
        Next J
    For I = Dau To Cuoi
        If sArr(I, 6) > dArr(K2 + 1, 6) Then
            For J = 1 To Col
                dArr(K2 + 1, J) = sArr(I, J)
            Next J
        End If
    Next I
Next N

đoạn code này của bate sai nhé, bạn áp dụng cẩn thận,

chỉ có Mmax đúng
vì code này lấy Mmin2 là cái cuối cùng, Mmin1 là tại cái thứ 2, có thể cẩn kiểm tra lại, hoặc hỏi bate lại xem sao???

Ba Tê · 18/7/14

vuivui85 đã viết:
đoạn code này của bate sai nhé, bạn áp dụng cẩn thận,

chỉ có Mmax đúng
vì code này lấy Mmin2 là cái cuối cùng, Mmin1 là tại cái thứ 2, có thể cẩn kiểm tra lại, hoặc hỏi bate lại xem sao???

Đồng ý với bạn luôn!
Và đó là điều dễ hiểu vì tôi là người "ngoại đạo", chỉ nhìn vào cấu trúc của bảng dữ liệu để tìm ra quy luật chung.
- 2 dòng đầu và 2 dòng cuối của mỗi tên dầm đều theo thứ tự BaoMax-BaoMin. Nếu không theo quy luật này thì "tèo".
(Thêm vài dòng so sánh Min-Max của từng cặp dòng này)
- Đầu đầm và cuối dầm không phải là cặp 2 dòng cũng "tèo".
(Sửa lại code "bấy nhậy" luôn)

nguyenkhoadng đã viết:
............................
a có thể giúp e lọc ngay tại sheet "TinhThep" được không a? và cứ mỗi 3 dòng Mmin, Mmax, Mmin thì tự động kẽ 1 dòng nét đứt phân chia ra cho dễ quan sát (giống file mẫu).

Thà giữ nguyên sheet mẫu để còn so sánh lại xem có sai sót gì không,
Bạn đã viết được 2 Module trong file, chuyện này là chuyện nhỏ mà.

nguyenkhoadng · 18/7/14

Ba Tê đã viết:
Thà giữ nguyên sheet mẫu để còn so sánh lại xem có sai sót gì không,
Bạn đã viết được 2 Module trong file, chuyện này là chuyện nhỏ mà.

hì hì, 2 module đó e cũng sưu tầm a ah

Cảm ơn các a đã nhiệt tình giúp đỡ!
Để code hoạt động đúng theo ý của người yêu cầu trong khi viết code lại là người khác thì thật ko phải dễ.

E có mò sửa sơ lại cái code sưu tầm bên dưới, giờ nó cũng tạm theo ý, tuy nó hoạt động ko được trơn tru lắm

Bây giờ nhờ các a giúp e thêm 1 đoạn code hide/unhide các dòng: lấy điều kiện là ở các ô của cột D tô đậm thì giữ lại, còn các dòng nào mà các ô ở cột D ko tô đậm thì ẩn đi (hide)

e cảm ơn!

Mã:

Sub RBeam()
 Dim RowCuoiBeam As Long, RowDauBeam As Long, Beam As Long
 Dim WorkOnBeam
 ActiveSheet.Unprotect
  n = 11
  Cells(n, "B").Select
  If Selection.Value = "" Then Exit Sub 'Neu B6 trong nghia la khong co Data
  Do While Cells(n, "B") <> ""
    Cells(n, "B").Select
    If Cells(n, "B").Value = Cells(n + 1, "B").Value Then
      n = n + 1
    Else
      RowCuoiBeam = n
      If RowDauBeam = 1 Then
        RowDauBeam = 11
      End If
      Beam = Beam + 1
      'MsgBox "Beam thu: " & Beam & " La: " & Cells(RowDauBeam, "B").Value & Chr(13) & _
      "RowDauBeam = " & RowDauBeam & Chr(13) & _
      "RowCuoiBeam = " & RowCuoiBeam & Chr(13) & _
      "Goi lenh to dam"
      WorkOnBeam = M3_Bold(RowDauBeam, RowCuoiBeam)  '?co khi nao goi Sub ma co lay gia tri 2 bien khong? Khong dung Function duoc khong?
      n = n + 1
    End If
    RowDauBeam = RowCuoiBeam + 1
  Loop
  Range("B" & RowCuoiBeam).Select
  ActiveSheet.Protect
End Sub


Function M3_Bold(RowDauBeam, RowCuoiBeam)
 Dim M3max, M3min1, Beam_All As Range, M3 As Range, Beam_Up As Range
 Dim M3min2, Beam_Dn As Range
 Dim Row_in_Beam As Long, RowM3max_In_Beam As Long, RowM3max As Long
 Dim RowM3min1_In_Beam As Long, RowM3min1 As Long, RowM3min2_In_Beam As Long
 Dim RowM3min2 As Long
 
  'Xac dinh vi tri M3max va to dam M3max
  Set Beam_All = Range(Cells(RowDauBeam, "F"), Cells(RowCuoiBeam, "F"))
  Beam_All.Select     'Minh hoa cho ro nghia (Delete)
  M3max = Beam_All(1).Value
  Row_in_Beam = 1
  For Each M3 In Beam_All
    'MsgBox M3.Value   'Minh hoa cho ro nghia (Delete)
    If M3.Value >= M3max Then
      M3max = M3.Value
      RowM3max_In_Beam = Row_in_Beam
    End If
    Row_in_Beam = Row_in_Beam + 1
  Next
  RowM3max = RowDauBeam + RowM3max_In_Beam - 1
  Cells(RowM3max, "D").Font.Bold = True
  Cells(RowM3max, "D").Font.ColorIndex = 1
  
  'Xac dinh vi tri M3min1 va to dam M3min1
  Set Beam_Up = Range(Cells(RowDauBeam, "F"), Cells(RowM3max - 1, "F"))
  Beam_Up.Select     'Minh hoa cho ro nghia (Delete)
  M3min1 = Beam_Up(1).Value
  Row_in_Beam = 1
  For Each M3 In Beam_Up
    'MsgBox M3.Value   'Minh hoa cho ro nghia (Delete)
    If M3.Value <= M3min1 Then
      M3min1 = M3.Value
      RowM3min1_In_Beam = Row_in_Beam
    End If
    Row_in_Beam = Row_in_Beam + 1
  Next
  RowM3min1 = RowDauBeam + RowM3min1_In_Beam - 1
  Cells(RowM3min1, "D").Font.Bold = True
  Cells(RowM3min1, "D").Font.ColorIndex = 1
  
  'Xac dinh vi tri M3min2 va to dam M3min2
  Set Beam_Dn = Range(Cells(RowM3max + 1, "F"), Cells(RowCuoiBeam, "F"))
  Beam_Dn.Select     'Minh hoa cho ro nghia (Delete)
  M3min2 = Beam_Dn(1).Value
  Row_in_Beam = 1
  For Each M3 In Beam_Dn
    'MsgBox M3.Value   'Minh hoa cho ro nghia (Delete)
    If M3.Value <= M3min2 Then
      M3min2 = M3.Value
      RowM3min2_In_Beam = Row_in_Beam
    End If
    Row_in_Beam = Row_in_Beam + 1
  Next
  RowM3min2 = RowM3max + RowM3min2_In_Beam
  Cells(RowM3min2, "D").Font.Bold = True
  Cells(RowM3min2, "D").Font.ColorIndex = 1
  M3_Bold = 0
End Function

vuivui85 · 18/7/14

nguyenkhoadng đã viết:
hì hì, 2 module đó e cũng sưu tầm a ah
Bây giờ nhờ các a giúp e thêm 1 đoạn code hide/unhide các dòng: lấy điều kiện là ở các ô của cột D tô đậm thì giữ lại, còn các dòng nào mà các ô ở cột D ko tô đậm thì ẩn đi (hide)

Bạn muốn ẩn (hidden) hay Xóa (Delete ) dòng đi???

Nếu muốn xóa thì xem bài tiếp

vuivui85 · 18/7/14

Trực tiếp xóa dòng, chỉ lại các dòng thỏa mãn Mmax, Mmin1, Mmin2

Đặt code sau vào module rồi tự gắn nút chạy vào (vẽ shape rui nháy phải chọn assign macro ...)

Mã:

Sub XOADONGDAM()
    If Not MsgBox("ban co chac chan Loc dam khong (Y/N)?", vbYesNo + vbDefaultButton2) = vbYes Then Exit Sub
    Application.ScreenUpdating = False
    Dim t:    t = Timer
    Dim ceL As Range
    Dim sArr1, sArr2, aRR
    Dim i As Long, n As Long, d As Long, c As Long, iM As Long, q As Long, k As Long
    Dim sT As String
    Dim iMin As Long
    
    Set ceL = [B65536].End(xlUp)
    sArr1 = Range([A11], ceL).Value2
    sArr2 = Range([F11], ceL.Offset(, 4)).Value2
    n = UBound(sArr1)
    ReDim aRR(1 To n) As Long
    
    i = 1: d = i: c = i: iM = i:  iMin = i
    For i = 2 To n
        If ((sArr1(i, 1) = sArr1(i - 1, 1)) And (sArr1(i, 2) = sArr1(i - 1, 2))) Then
            If sArr2(i, 1) > sArr2(iM, 1) Then iM = i
            If sArr2(i, 1) < sArr2(iMin, 1) Then iMin = i
            If i = n Then GoTo 1
        Else 'KHAC
1:
            c = IIf(i = n, i, i - 1)
            aRR(iM) = 1
            aRR(iMin) = 1
            
            If iMin > iM Then
                'Tim min1
                q = d
                For k = d + 1 To iM - 1
                    If sArr2(k, 1) < sArr2(q, 1) Then q = k
                Next
                aRR(q) = 1
            End If
            
            If iMin < iM Then
                'Tim min2
                q = c
                For k = c - 1 To iM + 1 Step -1
                    If sArr2(k, 1) < sArr2(q, 1) Then q = k
                Next
                aRR(q) = 1
            End If
            d = i: c = i: iM = i:  iMin = i
        End If
    Next i

    Dim Rng As Range
    
    Set Rng = [a65535]
    For i = 1 To n
        If aRR(i) <> 1 Then
            Set Rng = Union(Rng, [A10].Offset(i))
        End If
    Next i
    
    If Not Rng Is Nothing Then Rng.EntireRow.Delete
    For i = 3 To [A11].End(xlDown).Row - 10 - 3 Step 3
        With [A10].Offset(i).Resize(, 29).Borders(xlEdgeBottom)
            .LineStyle = xlDash
            .ColorIndex = 5
            .Weight = xlMedium
        End With
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "Ket thuc, thoi gian: " & Timer - t
End Sub

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

Thành viên hoạt động

File đính kèm

Thành viên gắn bó

Thành viên hoạt động

Thành viên gắn bó

Ăn cùng góc phố

Thành viên hoạt động

File đính kèm

Thành viên gắn bó

Thành viên hoạt động

Thành viên gắn bó

Thành viên gắn bó

Thành viên hoạt động

Cạo Rồi Khỏi Gội

File đính kèm

Thành viên gắn bó

Thành viên hoạt động

Thành viên hoạt động

Thành viên mới

Cạo Rồi Khỏi Gội

Thành viên hoạt động

File đính kèm

Thành viên mới

Thành viên mới

Đếm ngược thời gian