Code lọc nội lực VBA

NguyenTai1003 · 30/6/18

Em là sinh viên xây dựng và đang làm đồ án tốt nghiệp. Đến phần tính toán cốt thép cho dầm thì gặp chút xíu trở ngại. Anh (chị) nào có thể giúp em viết 1 đoạn code VBA để lọc nội lực của dầm được ko ạ, chứ lọc tay thì ngán quá, công trình 9 tầng, 7 nhịp, em làm khung phẳng. Mỗi phần tử dầm sẽ lọc nội lực tại 3 vị trí: Mmin (-) ở đầu dầm, Mmax (+) ở giữa dầm và Mmin (-) ở cuối dầm. Chỉ giữ lại những dòng thỏa mãn điều kiện, còn lại thì xóa đi. Em có file nội lực được xuất ra từ EATBS và 1 bảng mẫu đã được lọc sẵn. Mong anh (chị) trong diễn đàn giúp đỡ. Em cảm ơn nhiều ạ.

cantl · 11/9/24

Nếu tớ nhớ không lầm thì P là lực cắt, M2, M3 là momen uốn và xoắn, hay là momen 2 thớ nhỉ?
Tóm tắt thế này:
Tại từng cột:
- đầu cột - 0m: cần tìm giá trị Pmax hoặc M2 max hoặc M3 max (3 cái này không cùng max nên phải 3 dòng).
- giữa cột - 0.35m: -nt-
- cuối cột - 0.7m: -nt-

Cách của bạn huhumalu đúng kết quả nhưng chưa tự động phần tên cột và lý trình 0 0.35 0.7m. Nên code sẽ tiện hơn. Tuy nhiên, tớ không biết code nhé.
Bài này có lẽ Power Query hay Pivot gì đó sẽ dùng được. ĐOÁN.

Đồi Keo đã viết:
thủ công

Đồi Keo · 11/9/24

cantl đã viết:
Nếu tớ nhớ không lầm thì P là lực cắt, M2, M3 là momen uốn và xoắn, hay là momen 2 thớ nhỉ?
Tóm tắt thế này:
Tại từng cột:
- đầu cột - 0m: cần tìm giá trị Pmax hoặc M2 max hoặc M3 max (3 cái này không cùng max nên phải 3 dòng).
- giữa cột - 0.35m: -nt-
- cuối cột - 0.7m: -nt-

Cách của bạn huhumalu đúng kết quả nhưng chưa tự động phần tên cột và lý trình 0 0.35 0.7m. Nên code sẽ tiện hơn. Tuy nhiên, tớ không biết code nhé.
Bài này có lẽ Power Query hay Pivot gì đó sẽ dùng được. ĐOÁN.

P là lực dọc (thẳng đứng).
M2, M3 là momen uốn theo phương trục 2 và trục 3.
Mình có tìm hiểu Pivot (trên GPE). Nó giải quyết được vấn đề nhưng mình phải làm thủ công chút ạ.

cantl · 11/9/24

Đồi Keo đã viết:
P là lực dọc (thẳng đứng).
M2, M3 là momen uốn theo phương trục 2 và trục 3.
Mình có tìm hiểu Pivot (trên GPE). Nó giải quyết được vấn đề nhưng mình phải làm thủ công chút ạ.

à, P Q M, nhớ nhầm. Hề hề.

HieuCD · 11/9/24

Đồi Keo đã viết:
Trước khi lên diễn đàn GPE nhờ trợ giúp, tự bản thân cũng đã tìm trên diễn đàn GPE cũng như nhiều diễn đàn khác liên quan đến chủ đề:

Sheet dữ liệu 1 sắp xếp theo Column, cột Station có 3 dòng đi cặp như trong file
Sheet dữ liệu 2 sắp xếp theo Beam
Chạy 2 sub

Mã:

Option Explicit

Sub xyz()
  Dim arr(), res(), a, C, b, bT
  Dim sRow&, i&, r&, k&, j&, Col$
 
  bT = Array(0, 9999, 9999, -9999, 9999, -9999, 9999)
  C = Array(0, 1, 2, 3, 4, 6, 7, 8, 9, 11, 12)
  With Sheets("Sheet DuLieu 1")
    i = .Range("A1000000").End(xlUp).Row
    If i < 4 Then Exit Sub
    arr = .Range("A4:L" & i + 3).Value
    sRow = UBound(arr) - 3
  End With
 
  ReDim res(1 To sRow, 1 To 10)
  For i = 1 To sRow Step 3
    If Col <> arr(i, 2) Then
      ReDim a(1 To 6)
      b = bT
      Col = arr(i, 2)
    End If
    If Col = arr(i, 2) Then
      If b(1) > arr(i, 7) Then
        a(1) = i:        b(1) = arr(i, 7)
      End If
      If b(2) > arr(i, 11) Then
        a(2) = i:        b(2) = arr(i, 11)
      End If
      If b(3) < arr(i, 12) Then
        a(3) = i:        b(3) = arr(i, 12)
      End If
      If b(4) > arr(i + 2, 7) Then
        a(4) = i + 2:        b(4) = arr(i + 2, 7)
      End If
      If b(5) < arr(i + 2, 11) Then
        a(5) = i + 2:        b(5) = arr(i + 2, 11)
      End If
      If b(6) > arr(i + 2, 12) Then
        a(6) = i + 2:        b(6) = arr(i + 2, 12)
      End If
    
      If Col <> arr(i + 3, 2) Then
        For r = 1 To 6
          For j = 1 To 10
            res(k + r, j) = arr(a(r), C(j))
          Next j
        Next r
        k = k + 6
      End If
    End If
  Next i
 
  With Sheets("Sheet Ketqua 1")
    i = .Range("A1000000").End(xlUp).Row
    If i > 3 Then .Range("A4:K" & i).Clear
    .Range("A4").Resize(k, 10) = res
    .Range("A4").Resize(k, 10).Borders.LineStyle = 1
  End With
End Sub

Sub xyz2()
  Dim arr(), res(), a, C, b, bT, VT
  Dim sRow&, i&, r&, k&, j&, Beam$
 
  bT = Array(0, 9999, -9999, -9999, -9999, -9999)
  C = Array(0, 1, 2, 3, 4, 6, 7, 9, 13)
  VT = Array("", "GT", "NH", "NH", "NH", "GP")
  With Sheets("Sheet DuLieu 2")
    i = .Range("A1000000").End(xlUp).Row
    If i < 4 Then Exit Sub
    arr = .Range("A4:M" & i + 1).Value
    sRow = UBound(arr) - 1
  End With
 
  ReDim res(1 To sRow, 1 To 9)
  For i = 1 To sRow
    If Beam <> arr(i, 2) Then
      ReDim a(1 To 5)
      b = bT
      Beam = arr(i, 2)
    End If
    If Beam = arr(i, 2) Then
      If arr(i, 6) = "Min" Then
        If b(1) > arr(i, 7) Then
          a(1) = i:        b(1) = arr(i, 7)
        End If
        If b(5) < arr(i, 7) Then
          a(5) = i:         b(5) = arr(i, 7)
        End If
      Else
        For j = 2 To 4
          If b(j) < arr(i, 13) Then
            For r = 4 To j + 1 Step -1
              a(r) = a(r - 1):      b(r) = b(r - 1)
            Next r
            a(j) = i:         b(j) = arr(i, 13)
            Exit For
          End If
        Next j
      End If
    
      If Beam <> arr(i + 1, 2) Then
        For r = 1 To 5
          For j = 1 To 8
            res(k + r, j) = arr(a(r), C(j))
          Next j
          res(k + r, 9) = VT(r)
        Next r
        k = k + 5
      End If
    End If
  Next i
 
  With Sheets("Sheet Ketqua 2")
    i = .Range("A1000000").End(xlUp).Row
    If i > 3 Then .Range("A4:I" & i).Clear
    .Range("A4").Resize(k, 9) = res
    .Range("A4").Resize(k, 9).Borders.LineStyle = 1
  End With
End Sub

Đồi Keo · 12/9/24

HieuCD đã viết:

Sheet dữ liệu 1 sắp xếp theo Column, cột Station có 3 dòng đi cặp như trong file
Sheet dữ liệu 2 sắp xếp theo Beam
Chạy 2 sub

Mã:

Option Explicit

Sub xyz()
  Dim arr(), res(), a, C, b, bT
  Dim sRow&, i&, r&, k&, j&, Col$
 
  bT = Array(0, 9999, 9999, -9999, 9999, -9999, 9999)
  C = Array(0, 1, 2, 3, 4, 6, 7, 8, 9, 11, 12)
  With Sheets("Sheet DuLieu 1")
    i = .Range("A1000000").End(xlUp).Row
    If i < 4 Then Exit Sub
    arr = .Range("A4:L" & i + 3).Value
    sRow = UBound(arr) - 3
  End With
 
  ReDim res(1 To sRow, 1 To 10)
  For i = 1 To sRow Step 3
    If Col <> arr(i, 2) Then
      ReDim a(1 To 6)
      b = bT
      Col = arr(i, 2)
    End If
    If Col = arr(i, 2) Then
      If b(1) > arr(i, 7) Then
        a(1) = i:        b(1) = arr(i, 7)
      End If
      If b(2) > arr(i, 11) Then
        a(2) = i:        b(2) = arr(i, 11)
      End If
      If b(3) < arr(i, 12) Then
        a(3) = i:        b(3) = arr(i, 12)
      End If
      If b(4) > arr(i + 2, 7) Then
        a(4) = i + 2:        b(4) = arr(i + 2, 7)
      End If
      If b(5) < arr(i + 2, 11) Then
        a(5) = i + 2:        b(5) = arr(i + 2, 11)
      End If
      If b(6) > arr(i + 2, 12) Then
        a(6) = i + 2:        b(6) = arr(i + 2, 12)
      End If
  
      If Col <> arr(i + 3, 2) Then
        For r = 1 To 6
          For j = 1 To 10
            res(k + r, j) = arr(a(r), C(j))
          Next j
        Next r
        k = k + 6
      End If
    End If
  Next i
 
  With Sheets("Sheet Ketqua 1")
    i = .Range("A1000000").End(xlUp).Row
    If i > 3 Then .Range("A4:K" & i).Clear
    .Range("A4").Resize(k, 10) = res
    .Range("A4").Resize(k, 10).Borders.LineStyle = 1
  End With
End Sub

Sub xyz2()
  Dim arr(), res(), a, C, b, bT, VT
  Dim sRow&, i&, r&, k&, j&, Beam$
 
  bT = Array(0, 9999, -9999, -9999, -9999, -9999)
  C = Array(0, 1, 2, 3, 4, 6, 7, 9, 13)
  VT = Array("", "GT", "NH", "NH", "NH", "GP")
  With Sheets("Sheet DuLieu 2")
    i = .Range("A1000000").End(xlUp).Row
    If i < 4 Then Exit Sub
    arr = .Range("A4:M" & i + 1).Value
    sRow = UBound(arr) - 1
  End With
 
  ReDim res(1 To sRow, 1 To 9)
  For i = 1 To sRow
    If Beam <> arr(i, 2) Then
      ReDim a(1 To 5)
      b = bT
      Beam = arr(i, 2)
    End If
    If Beam = arr(i, 2) Then
      If arr(i, 6) = "Min" Then
        If b(1) > arr(i, 7) Then
          a(1) = i:        b(1) = arr(i, 7)
        End If
        If b(5) < arr(i, 7) Then
          a(5) = i:         b(5) = arr(i, 7)
        End If
      Else
        For j = 2 To 4
          If b(j) < arr(i, 13) Then
            For r = 4 To j + 1 Step -1
              a(r) = a(r - 1):      b(r) = b(r - 1)
            Next r
            a(j) = i:         b(j) = arr(i, 13)
            Exit For
          End If
        Next j
      End If
  
      If Beam <> arr(i + 1, 2) Then
        For r = 1 To 5
          For j = 1 To 8
            res(k + r, j) = arr(a(r), C(j))
          Next j
          res(k + r, 9) = VT(r)
        Next r
        k = k + 5
      End If
    End If
  Next i
 
  With Sheets("Sheet Ketqua 2")
    i = .Range("A1000000").End(xlUp).Row
    If i > 3 Then .Range("A4:I" & i).Clear
    .Range("A4").Resize(k, 9) = res
    .Range("A4").Resize(k, 9).Borders.LineStyle = 1
  End With
End Sub

Trước hết xin cảm ơn Chuyên Gia Hieu CD ạ.

Vì trong thâm tâm cứ nghĩ rằng sẽ không ai giúp mình đâu. Và tự tìm thêm các trường hợp na ná, tương tự trên các youtube để tìm tòi học hỏi thêm, rồi tự ghép nối cho bài toàn của chính mình ạ.

Nhưng bây giờ được Hieu CD trợ giúp và gửi Sub_ cho thì tốt quá rồi ạ.

I will try and feedback later. Thank you so much!

huhumalu · 12/9/24

HieuCD đã viết:
Sheet dữ liệu 1 sắp xếp theo Column, cột Station có 3 dòng đi cặp như trong file
Sheet dữ liệu 2 sắp xếp theo Beam
Chạy 2 sub

Mã:

Option Explicit

Hay làm 3 cái dict (dictP ; dictM2; dictM3) xuất mảng luôn anh

Đồi Keo · 12/9/24

HieuCD đã viết:
Sheet dữ liệu 1 sắp xếp theo Column, cột Station có 3 dòng đi cặp như trong file
Sheet dữ liệu 2 sắp xếp theo Beam
Chạy 2 sub

I have checked 2 Sub_VBA of you.
1. Kết quả Sub_xyz (Lọc Nội Lực Column) cho kết quả hoàn toàn trùng khớp với mong đợi ạ. Amazing!
2. Kết quả Sub_xyz2 (Lọc Nội Lực Beam) thì chỉ chỉnh sửa a little bit thì sẽ hoàn hảo ạ. Cõ lẽ đó là vì (my fault) đã ghi chú chưa được rõ ràng ạ.
P/s: Có ghi chú lại ở trong file ảnh ạ. Mong HieuCD xem ảnh, rồi điều chỉnh lại giúp nhé ạ.

VetMini · 12/9/24

huhumalu đã viết:
Hay làm 3 cái dict (dictP ; dictM2; dictM3) xuất mảng luôn anh

Hai bên trúng băng tầng rồi. Để họ tự ước lượng với nhau. Mình vô chi vậy?

Đồi Keo · 12/9/24

VetMini đã viết:
Hai bên trúng băng tầng rồi. Để họ tự ước lượng với nhau. Mình vô chi vậy?

Mình tự hỏi Bác VetMini giận lẫy mình sao ta? Nếu lỡ vô tình làm phiền lòng Bác. Mong Bác lượng thứ nhé ạ. Vì trên diễn đàn không biết ai là ai. Có khi Bác là cao thủ "Ẩn cùng góc phố" mà chưa chịu hiện hình đó ạ.

VetMini · 12/9/24

Mắc mớ gì phải giận.
Tôi chỉ buồn cười khi thấy người Việt cảm ơn nhau bằng tiếng Tây thôi.

HieuCD · 12/9/24

Đồi Keo đã viết:
I have checked 2 Sub_VBA of you.
1. Kết quả Sub_xyz (Lọc Nội Lực Column) cho kết quả hoàn toàn trùng khớp với mong đợi ạ. Amazing!
2. Kết quả Sub_xyz2 (Lọc Nội Lực Beam) thì chỉ chỉnh sửa a little bit thì sẽ hoàn hảo ạ. Cõ lẽ đó là vì (my fault) đã ghi chú chưa được rõ ràng ạ.
P/s: Có ghi chú lại ở trong file ảnh ạ. Mong HieuCD xem ảnh, rồi điều chỉnh lại giúp nhé ạ.

Mình chưa hiểu hết cách xử lý dữ liệu, bạn nên kiểm tra thêm các Beam khác

Mã:

Sub xyz2()
  Dim arr(), res(), a, C, b, bT, VT
  Dim sRow&, i&, r&, k&, j&, Beam$, vMax#
 
  bT = Array(0, 9999, -9999, -9999, -9999, -9999)
  C = Array(0, 1, 2, 3, 4, 6, 7, 9, 13)
  VT = Array("", "GT", "NH", "NH", "NH", "GP")
  With Sheets("Sheet DuLieu 2")
    i = .Range("A1000000").End(xlUp).Row
    If i < 4 Then Exit Sub
    arr = .Range("A4:M" & i + 1).Value
    sRow = UBound(arr) - 1
  End With
 
  ReDim res(1 To sRow, 1 To 9)
  For i = 1 To sRow
    If Beam <> arr(i, 2) Then
      ReDim a(1 To 5)
      b = bT
      vMax = -9999
      Beam = arr(i, 2)
    End If
    If arr(i, 6) = "Min" Then
      If b(1) > arr(i, 7) Then
        a(1) = i:        b(1) = arr(i, 7)
      End If
      If b(5) < arr(i, 7) Then
        a(5) = i:         b(5) = arr(i, 7)
      End If
    Else
      For j = 2 To 4
        If b(j) < arr(i, 13) Then
          For r = 4 To j + 1 Step -1
            a(r) = a(r - 1):      b(r) = b(r - 1)
          Next r
          a(j) = i:         b(j) = arr(i, 13)
          Exit For
        End If
      Next j
    End If
    If vMax < arr(i, 9) Then vMax = arr(i, 9)
   
    If Beam <> arr(i + 1, 2) Then
      For r = 1 To 5
        For j = 1 To 8
          res(k + r, j) = arr(a(r), C(j))
        Next j
        res(k + r, 9) = VT(r)
      Next r
      res(k + 5, 7) = vMax
      k = k + 5
    End If
  Next i
 
  With Sheets("Sheet Ketqua 2")
    i = .Range("A1000000").End(xlUp).Row
    If i > 3 Then .Range("A4:I" & i).Clear
    .Range("A4").Resize(k, 9) = res
    .Range("A4").Resize(k, 9).Borders.LineStyle = 1
  End With
End Sub

Tiếng Anh mình chưa rành lắm, giao tiếp bằng tiếng Việt dể hơn

Bài đã được tự động gộp: 12/9/24

huhumalu đã viết:
Hay làm 3 cái dict (dictP ; dictM2; dictM3) xuất mảng luôn anh

Dạng nầy sort dữ liệu tiện hơn dùng dic

cantl · 12/9/24

Cách dùng tiếng Anh của bạn này rất hay.
Thường song ngữ là 2 câu đều có nghĩa giống nhau, nhưng bạn này song ngữ theo kiểu Anh Việt so le.

Đồi Keo · 13/9/24

HieuCD đã viết:
Mình chưa hiểu hết cách xử lý dữ liệu, bạn nên kiểm tra thêm các Beam khác

Kết quả đã được như ý rồi ạ.
Xin chân thành cảm ơn HieuCD nhiều lắm ạ.

Bài đã được tự động gộp: 13/9/24

VetMini đã viết:
Mắc mớ gì phải giận.
Tôi chỉ buồn cười khi thấy người Việt cảm ơn nhau bằng tiếng Tây thôi.

Dạ. Khi thương trái ấu cùng tròn.
Khi ghét trái bồ hòn cũng vuông

Thương người thương cả tông ti
Ghét người ghét cả đường đi lối về.

Có lẽ Bác là người lớn tuổi, hiểu biết nhiều chắc sẽ không quá khó khăn với lớp trẻ sau này ạ.
Một lần nữa dù không biết Bác là ai... Nhưng mong Bác lượng thứ cho những điều đã vô tình làm Phật lòng Bác ạ.

HUONGHCKT · 13/9/24

Đồi Keo đã viết:
Kết quả đã được như ý rồi ạ.

Bạn đã được hưởng lợi từ Diễn đàn và sự trợ giúp tận tình của Anh @HieuCD rồi.
Nếu bạn có Tâm và thiện chí, HÃY đọc và HÀNH ĐỘNG cho đúng với lương tâm mình và tiếng gọi của sự trắc ẩn đang tồn tại nơi bạn.

[KHẨN] HƯỚNG VỀ ĐỒNG BÀO CHỊU ẢNH HƯỞNG CỦA BÃO YAGI - BẢO YÊN, LÀO CAI

KÊU GỌI QUYÊN GÓP CÙNG HƯỚNG VỀ NHỮNG GIA ĐÌNH BỊ ẢNH HƯỞNG BỞI LŨ LỤT SAU BÃO SỐ 3 YAGI TẠI HUYỆN BẢO YÊN – LÀO CAI Kính gửi thành viên diễn đàn GIẢI PHÁP EXCEL.COM, Miền Bắc nước ta vừa trải qua một cơn bão lịch sử – bão số 3 Yagi đã gây ra những thiệt hại nặng nề cho nhiều vùng miền, đặc...

www.giaiphapexcel.com

Đáng quý biết bao, dù ít, dù nhiều cũng là làm xoa dịu nỗi đau Yagi.

Code lọc nội lực VBA

NguyenTai1003

Thành viên mới

File đính kèm

cantl

!!! Giải thoát !!!

Đồi Keo

Thành viên mới

cantl

!!! Giải thoát !!!

HieuCD

Chuyên gia GPE

Đồi Keo

Thành viên mới

huhumalu

Thành viên tích cực

Đồi Keo

Thành viên mới

File đính kèm

VetMini

Ăn cùng góc phố

Đồi Keo

Thành viên mới

VetMini

Ăn cùng góc phố

HieuCD

Chuyên gia GPE

cantl

!!! Giải thoát !!!

Đồi Keo

Thành viên mới

HUONGHCKT

Zalo 0986997214

[KHẨN] HƯỚNG VỀ ĐỒNG BÀO CHỊU ẢNH HƯỞNG CỦA BÃO YAGI - BẢO YÊN, LÀO CAI

Bài viết mới nhất

Đếm ngược thời gian

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng