Tối ưu code vba lọc dữ liệu (1 người xem)

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

hungpecc1 · 18/7/14

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

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 · 18/7/14

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

Mã:

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 · 18/7/14

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

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)

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

Mã:

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 · 19/7/14

vuivui85 đã viết:
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 · 19/7/14

hungpecc1 đã viết:
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 · 19/7/14

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 · 19/7/14

vuivui85 đã viết:
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 · 19/7/14

nguyenkhoadng đã viế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.

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 đó

Mã:

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 · 19/7/14

vuivui85 đã viết:

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 đó

Mã:

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 · 19/7/14

nguyenkhoadng đã viết:
Đ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 · 19/7/14

nguyenkhoadng đã viết:
Đ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 · 20/7/14

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

Mã:

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 · 20/7/14

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ê · 21/7/14

nguyenkhoadng đã viế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 · 21/7/14

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 · 3/3/20

Ba Tê đã viết:
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 · 3/3/20

- 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 · 3/3/20

SA_DQ đã viết:
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 · 3/3/20

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 · 4/3/20

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

HieuCD · 4/3/20

authority đã viế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

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

Mã:

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ê · 4/3/20

authority đã viế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 · 4/3/20

Ba Tê đã viết:
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

HieuCD đã viết:

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

Mã:

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

Tối ưu code vba lọc dữ liệu (1 người xem)

Người dùng đang xem chủ đề này

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ó

Đang đi tìm hòn đá

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

Thành viên gắn bó

Thành viên mới

Thành viên mới

Thành viên gắn bó

Thành viên mới

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

Thành viên gắn bó

Thành viên mới

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

File đính kèm

Thành viên gắn bó

Thành viên mới

Thành viên mới

Thành viên mới

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

File đính kèm

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

Thành viên chính thức

File đính kèm

/(hông là gì!

Thành viên chính thức

/(hông là gì!

File đính kèm

Thành viên chính thức

File đính kèm

Chuyên gia GPE

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

File đính kèm

Thành viên chính thức

Thời gian đếm ngược.