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!

 

[hungpecc1]

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!

Mình cũng không phải là xây dựng, chỉ là biết chút ít thôi!
Nếu mà lọc theo ý của bạn thì cũng không phức tạp lắ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
    Dim tmpArr, tmp, Arr(), ArrIndex(1 To 3), ArrLength(1 To 3)
    Dim i&, j&, index, str$, n&
        tmpArr = Range("A11", [F65536].End(3))
        ReDim Arr(1 To UBound(tmpArr, 1), 1 To 5)
'________________________________________________________________
        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) = CDbl(tmpArr(i, 6)):         Arr(n, 5) = CDbl(tmpArr(i, 6))
                    Else
                        j = .Item(tmp)
                        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))
                            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))
                                    End If
                        End Select
                        If cdbl(tmpArr(i, 6)) > Arr(j, 4) Then
                            Arr(j, 4) = cdbl(tmpArr(i, 6)): Arr(j, 1)(2) = i
                        End If
                    End If
                End If
            Next
        End With
'_________________________To mau du lieu tim thay________________________________________________________________________________
        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
                Cells.Interior.Color = xlNone
                For i = 1 To UBound(tmpArr)
                    If Not tmpArr(i) Then
                        For j = i To UBound(tmpArr)
                            If tmpArr(j) Then
                                str = str & i + 10 & ":" & j + 9 & ","
                                i = j
                                Exit For
                            End If
                        Next
                    End If
                Next
                On Error Resume Next
                Range(Left(str, Len(str) - 1)).Delete
            '_______Lam dep + ke khung_____________________________________________________________
                For Each index In Array(9, 12)
                    Range("A11:AC11").Resize(n * 3).Borders(index).LineStyle = xlNone
                Next
                For i = 3 To n * 3
                    j = i + 10
                    With Range("A" & j & ":AC" & j).Borders(9)
                        .Color = vbBlue
                        .LineStyle = xlDash
                        .Weight = xlMedium
                    End With
                    i = i + 2
                Next
            End If
        End If
        Application.ScreenUpdating = True
End Sub

Chỉ có chính bạn mới hiểu bạn cần gì và muốn gì, code của anh Bate cũng như của mình , chỉ mang tính tham khảo, gợi ý về giải thuật đường đi, bạn phải tự ngâm cứu và tùy biến phù hợp với mình !
"Đọc kỹ hướng dẫn sử dụng trước khi dùng , không dùng với các thành phần mẫn cảm với thuốc "

 

[vuivui85]

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 ...)

Muốn cải thiện tốc độ nhanh hơn nữa , thì dùng cái này lọc tại chỗ ==> kết quả chỉ là VALUE (trường hợp có công thức sẽ mất)

code sau gán giá trị kết quả vào tại sheet nguồn.


cho code vào module, rồi tự gán nút mà chạy

Sub LapBangMoMenDamTaiCho()
    
    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 nguon, aiK, ik As Long
    Dim i As Long, n As Long, d As Long, c As Long, iM As Long, q As Long, k As Long, nC As Long
    Dim sT As String
    Dim iMin As Long
    
    With ActiveSheet
        Set ceL = .[B65536].End(xlUp)
        nguon = Range(.[A11], .Range("AC" & ceL.Row)).Value
    End With
    
    Set ceL = [A11] ' luu ket qua
    
    nC = UBound(nguon, 2)
    n = UBound(nguon)
     
    ReDim aiK(1 To 1)
    
    ik = 0
    i = 1: d = i: c = i: iM = i:  iMin = i
    For i = 2 To n
        If ((nguon(i, 1) = nguon(i - 1, 1)) And (nguon(i, 2) = nguon(i - 1, 2))) Then
            If nguon(i, 6) > nguon(iM, 6) Then iM = i
            If nguon(i, 6) < nguon(iMin, 6) Then iMin = i
            If i = n Then GoTo 1
        Else 'KHAC
1:          c = IIf(i = n, i, i - 1)
            If iMin = iM Then
                ik = ik + 1: ReDim Preserve aiK(1 To ik): aiK(ik) = iM
            ElseIf iMin > iM Then
                'Tim min1
                q = d
                For k = d + 1 To iM - 1
                    If nguon(k, 6) < nguon(q, 6) Then q = k
                Next
                ik = ik + 1: ReDim Preserve aiK(1 To ik): aiK(ik) = q
                ik = ik + 1: ReDim Preserve aiK(1 To ik): aiK(ik) = iM
                ik = ik + 1: ReDim Preserve aiK(1 To ik): aiK(ik) = iMin
            Else 'If iMin < iM Then
                'Tim min2
                q = c
                For k = c - 1 To iM + 1 Step -1
                    If nguon(k, 6) < nguon(q, 6) Then q = k
                Next
                ik = ik + 1: ReDim Preserve aiK(1 To ik): aiK(ik) = iMin
                ik = ik + 1: ReDim Preserve aiK(1 To ik): aiK(ik) = iM
                ik = ik + 1: ReDim Preserve aiK(1 To ik): aiK(ik) = q
            End If
            d = i: c = i: iM = i:  iMin = i
        End If
    Next i
    
    ReDim ketqua(1 To ik, 1 To nC)
    For i = 1 To ik
        For k = 1 To nC
            ketqua(i, k) = nguon(aiK(i), k)
        Next k
    Next i
    
    ceL.Resize(10000, nC).ClearContents
    
    ceL.Resize(ik, nC).Value = ketqua
    ceL.Offset(ik).Resize(10000 - ik, nC).Borders.LineStyle = 0
    For i = 3 To ik - 3 Step 3
        With ceL.Offset(i - 1).Resize(, nC).Borders(xlEdgeBottom)
            .LineStyle = xlDash
            .ColorIndex = 5
            .Weight = xlMedium
        End With
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "Ket thuc, thoi gian: " & Timer - t
End Sub

 

[vuivui85]

nếu muốn ẩn thì dùng cái ni

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)

nhanh nữa và chỉ ẩn dòng thì dùng code này
Đặ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 ...)

Sub anDONGDAM()
    If Not MsgBox("ban co chac chan Loc AN 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.Hidden = True
    Application.ScreenUpdating = True
    MsgBox "Ket thuc, thoi gian: " & Timer - t
End Sub

 

[hungpecc1]

nhanh nữa và chỉ ẩn dòng thì dùng code này
Đặ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 ...)

Nhìn qua code của bạn hình như code sẽ chỉ chạy đúng với điều kiện tên tầng + tên dầm phải được sắp xếp theo từng nhóm từ trên xuống dưới , ví dụ:
* nếu chèn thêm 1 dòng bất kỳ ở cuối , hay ở giữa là Story 1, Dầm B1 , cho giá trị M = -10000 --> chắc chắn code của bạn sẽ lọc được 4 giá trị B1 !
Hầu hết trong bảng tính sẽ có công thức tại một ô cells nào đó ,việc clearcontents toàn bộ, paste value kết quả lọc được, mình thấy không hợp lý, có lẽ tác giả muốn xóa dòng nhưng vẫn giữ công thức tại các dòng còn lại !

 

[vuivui85]

Nhìn qua code của bạn hình như code sẽ chỉ chạy đúng với điều kiện tên tầng + tên dầm phải được sắp xếp theo từng nhóm từ trên xuống dưới , ví dụ:
* nếu chèn thêm 1 dòng bất kỳ ở cuối , hay ở giữa là Story 1, Dầm B1 , cho giá trị M = -10000 --> chắc chắn code của bạn sẽ lọc được 4 giá trị B1 !
Hầu hết trong bảng tính sẽ có công thức tại một ô cells nào đó ,việc clearcontents toàn bộ, paste value kết quả lọc được, mình thấy không hợp lý, có lẽ tác giả muốn xóa dòng nhưng vẫn giữ công thức tại các dòng còn lại !

Hiện dữ liệu người hỏi đang sắp xếp theo nhóm, và thuật toán cũ của người hỏi cũng là xử lý nhóm, Nên ở đây để tránh việc dùng dictionary, thì giả định việc phân nhóm này là chuẩn xác

Mà về nguyên tắc tính toán Dầm cũng phải sắp xếp và trình tự mặt cắt dầm theo đúng thứ tự định vị của tọa độ --> nếu mặt cắt dầm sắp lun tung ngay trong 1 dầm (chưa nói là lẫn vào dầm khác) thì không bao giờ xác định đúng Mmin1, Min2 (trái phải) chuẩn theo được, do đó giả định trên là thực tế

còn nữa thì để người hỏi tự xác định, và tự tìm hiểu code, hạn chế của nó ứng dụng cho đúng.

-------------
Về xóa dòng , công thức: thì trên có code bài #20 cho người hỏi chọn - xóa cả dòng tại chỗ, hơn nữa bài #22 còn ẩn dòng giữ nguyên dòng, dữ liệu - dùng cái gì người hỏi sẽ quyết định. Còn cứ suy luận ra thì ra cả đống thứ.

 

[nguyenkhoadng]

Cảm ơn các a nhiều!
Đoạn code "anDONGDAM" của a vuivui85, nhờ a thêm phần tô đậm các ô BAO MIN, BAO MAX, BAO MIN được chọn, để khi unhide để kiểm tra ta có thể dễ dàng nhìn thấy cặp nội lực được chọn để tính toán.

 

[hungpecc1]

Mà về nguyên tắc tính toán Dầm cũng phải sắp xếp và trình tự mặt cắt dầm theo đúng thứ tự định vị của tọa độ --> nếu mặt cắt dầm sắp lun tung ngay trong 1 dầm (chưa nói là lẫn vào dầm khác) thì không bao giờ xác định đúng Mmin1, Min2 (trái phải) chuẩn theo được, do đó giả định trên là thực tế

Đồng ý, mình xin chia sẻ thêm 1 vài điều :
Nếu là trực tiếp từ SAP, ETAB,... thì dữ liệu xuất ra luôn được phân nhóm, và vị trí mặt cắt luôn đươc sắp xếp tăng dần ( so với mốc của trục tọa độ địa phương của Frame). Tuy nhiên khi đã đưa ra file excel người dùng có thể tự chỉnh sửa , copy paste dữ liệu từ nơi này sang nơi khác , --> đây là vấn đề rất hay xảy ra , do đó viết code phải chú ý đến trường hợp này !

nếu mặt cắt dầm sắp lun tung ngay trong 1 dầm (chưa nói là lẫn vào dầm khác) thì không bao giờ xác định đúng Mmin1, Min2 (trái phải) chuẩn theo được,

chưa hiểu ý trên lắm :
Mmin1 ,Min2 luôn có giá trị tương ứng với mặt cắt (Frame Section) , ta luôn tìm theo 2 tiêu chí : giá trị M và vị trí mặt căt --> do đó dữ liệu có lung tung ta vẫn có thể tìm được
==> kết luận :
** Đơn giản nhất là người dùng tạo một thủ tục sắp xếp (vd :custom sort trong excel) theo tên tầng + tên dầm :
** Lựa chọn code nào đã có trong topic phù hợp với bạn nhất là ok !

 

[vuivui85]

Cảm ơn các a nhiều!
Đoạn code "anDONGDAM" của a vuivui85, nhờ a thêm phần tô đậm các ô BAO MIN, BAO MAX, BAO MIN được chọn, để khi unhide để kiểm tra ta có thể dễ dàng nhìn thấy cặp nội lực được chọn để tính
toán.

tô cả màu xanh cho bạn rồi đó, nếu không thích thì bỏ đi, tôi đã ghi chú ở gần cuối code đó

Sub anDONGDAM()
    If Not MsgBox("ban co chac chan Loc AN 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
    
    
    For i = 1 To n
        If aRR(i) <> 1 Then
            If Rng Is Nothing Then
                Set Rng = [A10].Offset(i)
            Else
                Set Rng = Union(Rng, [A10].Offset(i))
            End If
        Else
            With [A10].Offset(i, 3).Font
                .Bold = True
                .Color = vbBlue 'neu khong thich mau thi bo dong nay di
            End With
        End If
    Next i
    
    If Not Rng Is Nothing Then Rng.EntireRow.Hidden = True
    Application.ScreenUpdating = True
    MsgBox "Ket thuc, thoi gian: " & Timer - t
End Sub

 

[nguyenkhoadng]

tô cả màu xanh cho bạn rồi đó, nếu không thích thì bỏ đi, tôi đã ghi chú ở gần cuối code đó

Sub anDONGDAM()
    If Not MsgBox("ban co chac chan Loc AN 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
    
    
    For i = 1 To n
        If aRR(i) <> 1 Then
            If Rng Is Nothing Then
                Set Rng = [A10].Offset(i)
            Else
                Set Rng = Union(Rng, [A10].Offset(i))
            End If
        Else
            With [A10].Offset(i, 3).Font
                .Bold = True
                .Color = vbBlue 'neu khong thich mau thi bo dong nay di
            End With
        End If
    Next i
    
    If Not Rng Is Nothing Then Rng.EntireRow.Hidden = True
    Application.ScreenUpdating = True
    MsgBox "Ket thuc, thoi gian: " & Timer - t
End Sub

Đoạn code có chút vấn đề a ah:
1. nếu dòng Mmax ở trên Mmin1 thì sẽ ko tìm Mmin2 nữa, lúc đó đoạn code chỉ tìm được Mmax và Mmin1 thôi (Ví dụ dầm B1 story 1)
2. Trình tự đoạn code tìm Mmin1, Mmax, Mmin2. nếu trong dầm có vị trí từ trên xuống Mmin1, Mmin2, Mmax thì code chỉ tìm được Mmin1 và Mmax (Ví dụ dầm B10 story 1)

 

[hungpecc1]

Đoạn code có chút vấn đề a ah:
1. nếu dòng Mmax ở trên Mmin1 thì sẽ ko tìm Mmin2 nữa, lúc đó đoạn code chỉ tìm được Mmax và Mmin1 thôi (Ví dụ dầm B1 story 1)
2. Trình tự đoạn code tìm Mmin1, Mmax, Mmin2. nếu trong dầm có vị trí từ trên xuống Mmin1, Mmin2, Mmax thì code chỉ tìm được Mmin1 và Mmax (Ví dụ dầm B10 story 1)

*Như đã nói code chỉ để bạn tham khảo và định hướng đi, do đó để phù hợp với yêu cầu của bạn thì bạn phải tự kiểm tra ,tuỳ biến sao cho phù hợp !
* Code của bạn Vuivui85 tương đối rõ ràng dễ hiểu bạn có thể chỉnh sửa thêm
* Còn nếu trường hợp như bạn nêu trên , tôi thấy code ở bài #21 của mình vẫn tìm đủ 3 tiết diện Mmax, Min đầu dầm, Min cuối dầm (như bạn miêu tả ban đầu),trường hợp muốn tìm Mín đầu dầm và Max giữa dầm tôi cũng đã code ở bài trược ,! nếu còn trường hợp nào khác cũng mình cũng xin chuồn chuồn thôi ,

 

[vuivui85]

Đoạn code có chút vấn đề a ah:
1. nếu dòng Mmax ở trên Mmin1 thì sẽ ko tìm Mmin2 nữa, lúc đó đoạn code chỉ tìm được Mmax và Mmin1 thôi (Ví dụ dầm B1 story 1)
2. Trình tự đoạn code tìm Mmin1, Mmax, Mmin2. nếu trong dầm có vị trí từ trên xuống Mmin1, Mmin2, Mmax thì code chỉ tìm được Mmin1 và Mmax (Ví dụ dầm B10 story 1)

Nếu cần tìm như thế phải định nghĩa lại các max, min1, min2...

còn nếu list hết các đỉnh của biểu đồ M thì ví dụ STORY1 B1 sẽ cần liệt kê max / min tới 5 vị trí tại M (cột F):

24.8
-31.07
24.19
-1.35
16.6
-29.48

nên chắc bạn tự suy nghĩ và làm theo ý mình thui

 

[vuivui85]

Theo y.c của chủ topic, sửa lại thế này cho tối ưu và lấy đúng Mmin1, Mmin2, Mmax

Sub Short()
ActiveSheet.Unprotect
'    If Not MsgBox("ban co chac chan Loc AN dam khong (Y/N)?", vbYesNo + vbDefaultButton2) = vbYes Then Exit Sub
    Application.ScreenUpdating = False
' Kiem tra du lieu Bang tinh thep
    If [b11].Value = "" Then Exit Sub 'Neu B11 trong nghia la khong co Data

'   Dim t:    t = Timer
    Dim sArr, Marr, iAk, DIC
    Dim ceL As Range, sT As String
    Dim i As Long, n As Long, k As Long, Nk As Long
    
    Set ceL = [B65536].End(xlUp)
    sArr = Range([A11], ceL.Offset(, 1)).Value2
    Marr = Range([F11], ceL.Offset(, 4)).Value2
    
    n = UBound(sArr)
    
    If Nk > 0 Then
        Dim Rng As Range, RngS As Range, Rng1 As Range, Rng2 As Range
        Set Rng = Range([b11], ceL).Offset(, 2).Resize(, 3)
        
        With Rng.Font 'xoa net dam va mau cua font truoc do
            ''.Bold = False
            .ColorIndex = 0
        End With
        Rng.Interior.ColorIndex = 0
        Rng.EntireRow.Hidden = True
        
        Set Rng = [d65536]
        Set Rng1 = [e65536]
        Set Rng2 = [f65536]
        For k = 1 To Nk
            With [d10]
                Set RngS = Union(.Offset(iAk(1, k)).Resize(, 3), .Offset(iAk(2, k)).Resize(, 3), .Offset(iAk(3, k)).Resize(, 3))
            End With
            Set Rng = Union(Rng, RngS)
            If k Mod 2 = 0 Then
                Set Rng2 = Union(Rng2, RngS)
            Else
                Set Rng1 = Union(Rng1, RngS)
            End If
        Next k
        Rng.EntireRow.Hidden = False
        Rng1.Interior.ColorIndex = 15
        Rng2.Interior.ColorIndex = 36
        
        With Rng.Font
            '.Bold = True
            .Color = vbBlue 'neu khong thich mau thi bo dong nay di
        End With
    Else
        MsgBox "BAI TOAN KHONG THOA MAN"
    End If
    
    Application.ScreenUpdating = True
'   MsgBox "Ket thuc, thoi gian: " & Timer - t
ActiveSheet.Protect
End Sub

 

[vuivui85]

XÓA dòng thừa này đi ở bài trên
ReDim aRR(1 To n) As Long

vì aRR không sử dụng, không xóa cũng không ảnh hưởng kết quả

 

[Ba Tê]

Cảm ơn các a nhiều!
Đoạn code "anDONGDAM" của a vuivui85, nhờ a thêm phần tô đậm các ô BAO MIN, BAO MAX, BAO MIN được chọn, để khi unhide để kiểm tra ta có thể dễ dàng nhìn thấy cặp nội lực được chọn để tính toán.

Lọc ra ở sheet GPE, muốn tô màu thì về sheet TinhThep, thử xem sao chứ Hide và Unhide từng dòng chắc chắn là chậm rồi.

 

[nguyenkhoadng]

Lại thêm 1 code hay để e học tập đây.
Code của a vì xuất sang sheet mới nên nhanh, lại bố trí được các vị trí min, max, min theo thứ tự rất đẹp.
Vì file excel của e đang có dự định làm chứa khá nhiều sheet nên e ngại phải thêm sheet lắm a, e thấy hide/unhide của a vuivui85 tốc độ cũng khá nhanh, tất cả các thao tác chỉ trên 1 sheet khá tiện.

Rất cảm ơn 2 a đã nhiệt tình hỗ trợ!
Chúc 2 a luôn vui!

 

[authority]

Lọc ra ở sheet GPE, muốn tô màu thì về sheet TinhThep, thử xem sao chứ Hide và Unhide từng dòng chắc chắn là chậm rồi.

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

 

[SA_DQ]

- 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)

Nhưng ở 1 hàng, luôn có phần tử trùng với tên dầm thì lọc sao được, nhỉ?

 

[authority]

Nhưng ở 1 hàng, luôn có phần tử trùng với tên dầm thì lọc sao được, nhỉ?

phương án em sẽ kết hợp tên phần tử&tên dầm thành 1 ạ
ví dụ: phần tử :b75, tên dầm : b75 thì dòng đó sẽ là b75b75

 

[SA_DQ]

Hơn chục năm nay, sau Tết luôn có bài kiểu như vầy; Nhưng là lần đầu tiên thấy dữ liệu như thế này!

 

[authority]

Hơn chục năm nay, sau Tết luôn có bài kiểu như vầy; Nhưng là lần đầu tiên thấy dữ liệu như thế này!

dạ đầu tiên em cảm ơn anh ạ
cách của anh thì phải chọn dầm anh à
Mong muốn của em là khi lọc xong là giữ lại giá trị lớn nhất và nhỏ nhất luôn anh à
ví dụ khi lọc xong dầm b75 thì giá trị lớn nhất là 3.78 và giá trị nhỏ nhất là -5.24
em đã giữ đc phần max 3.78, còn phần nhỏ nhất vẫn chưa đúng anh à
em cảm ơn