Tối ưu code cho combobox

[NH_DK]

Em đã viết:

Option Explicit

Private Sub ComboBox1_Change()
    Dim fRng As Range
  Dim er As Long
  Application.ScreenUpdating = False
  On Error Resume Next
    Set fRng = S1.Range("J:J").Find(Range("D8").Value, , xlValues, xlWhole)
    If Not fRng Is Nothing Then
      S14.Range("A14:K65000").Clear
      With S1.Range(S1.[a2], S1.[a65000].End(3)).Offset(1).Resize(, 20)
            .AutoFilter 2, ">=" & CLng(Range("E5").Value), 1, "<=" & CLng(Range("E6").Value)
            .AutoFilter 1, "PX*"
            .AutoFilter 10, Range("D8").Value
            Union(.Offset(1, 1).Resize(, 3), .Offset(1, 8).Resize(, 1)).SpecialCells(12).Copy S14.[a14]
            Union(.Offset(1, 12).Resize(, 1), .Offset(1, 16).Resize(, 2)).SpecialCells(12).Copy S14.[f14]
            .Offset(1, 19).Resize(, 1).SpecialCells(12).Copy S14.[k14]
            .AutoFilter
      End With
      Dim iR As Long, dongcuoi As Long
      iR = Range("A30000").End(3).Row
      With S14
        For dongcuoi = iR To 14 Step -1
          If .Cells(dongcuoi, 1) & .Cells(dongcuoi, 2) & .Cells(dongcuoi, 3) = .Cells(dongcuoi - 1, 1) & .Cells(dongcuoi - 1, 2) & _
          .Cells(dongcuoi - 1, 3) Then .Cells(dongcuoi, 1).Resize(, 3) = Empty
        Next
      End With
      S6.[A54:K61].Copy S14.[A65536].End(3).Offset(1)
      With Range("A13").Offset(1).Resize(iR - 13, 11)
            .BorderAround LineStyle:=1
            .Borders(11).LineStyle = 1: .Borders(11).ColorIndex = 1
            .Borders(12).LineStyle = 1: .Borders(12).ColorIndex = 1: .Borders(xlInsideHorizontal).Weight = xlThin
      End With
      With S14
        .Cells(iR + 2, 8).Formula = "=SUM(R14C:R[-2]C)"
        .Cells(iR + 2, 11).Formula = "=SUM(R14C:R[-2]C)"
        .Cells(iR + 3, 8).Value = .Cells(iR + 2, 8).Value
        .Cells(iR + 4, 8).Value = .Cells(iR + 2, 11).Value
        .Cells(iR + 5, 8).Value = "=R[-2]C-R[-1]C"
        .Cells(iR + 2, 8).Value = .Cells(iR + 2, 8).Value
        .Cells(iR + 2, 11).Value = .Cells(iR + 2, 11).Value
        .Cells(iR + 5, 8).Value = .Cells(iR + 5, 8).Value
      End With
    End If
End Sub

Nhờ mọi người tối ưu code này cho em nhé!

 

[NH_DK]

Một lưu ý nữa: Sao em thiết lập code này thì tại sheet gốc (Sheet S1) sao không dùng filter được. Cứ thiết lập filter xong là nó tự động huỷ thui ah.
Em đã tìm cách xử lý nhưng vẫn khống biết nguyên nhân? Nhờ mọi người xem dùm cho em!

 

[ptm0412]

1. Dùng mảng thay vì Autofilter và copy
2. Viết 1 code có thể dùng nhiều lần, nhiều chỗ và gọi nó khi cần thiết:

Sub Addborder(Rng As Range)
For i = 7 To 12
On Error Resume Next
    With Rng.Borders(i)
        .LineStyle = 1
        .Weight = IIf(i = 12, 1, 2)
    End With
Next
End Sub

Sub Main1()
Code làm việc
AddBorder Sheets("abc").Range("Vùng cần kẻ khung")
Code khác nếu có
End Sub

3. Đưa code mà không đưa file, ai biết S14 là cái gì. Ngoài ra, không có file thì làm sao người ta test lỗi Filter? Dù cho người ta muốn tạo dữ liệu giả lập, ai biết D8, E5, E6 chứa con khỉ gì, cột 1, cột 2, cột 10 dữ liệu dạng gì? Ai biết combobox link vào cell nào?

 

[NH_DK]

Vâng nhờ sư phụ và mọi người xem dùm cho em nhé!
Download

 

[ndu96081631]

Vâng nhờ sư phụ và mọi người xem dùm cho em nhé!
Download

Chẳng download được! Bạn xem lại nhé

 

[NH_DK]

Chẳng download được! Bạn xem lại nhé

View attachment 75960

Chết thật em sơ xuất quá! Mà giờ lại đang ở Cty nên không có file đó. Tối em gửi lên nhờ sư phụ xem dùm em nhé!

 

[NH_DK]

Đây là link em up lại. Nhờ sư phụ và moi người giúp cho em!

 

[nghiaphuc]

Đây là link em up lại. Nhờ sư phụ và moi người giúp cho em!

Chú này lạ nhỉ?! Đưa file lên để nhờ xem code mà chú khóa VBAProject lại thì ai mà xem được?!

 

[NH_DK]

Ui, em lại quên mất chứ! Đãng trí quá...!!
Download

 

[NH_DK]

Mọi người xem dùm cho em với nhé! Em đang cần lắm. Tìm mãi vẫn không khắc phục được!

 

[ndu96081631]

Mọi người xem dùm cho em với nhé! Em đang cần lắm. Tìm mãi vẫn không khắc phục được!

Để test code, bạn bỏ dòng On Error Resume Next đi sẽ biết code lỗi chổ nào liền chứ gì

 

[NH_DK]

Để test code, bạn bỏ dòng On Error Resume Next đi sẽ biết code lỗi chổ nào liền chứ gì

Em làm như một sư phụ rùi và đã biết lỗi. Vậy em phải sửa chỗ đó như thế nào để sheet CSDL có thể lọc được?

.AutoFilter 10, Range("D8").Value

 

[tintam7251]

Em làm như một sư phụ rùi và đã biết lỗi. Vậy em phải sửa chỗ đó như thế nào để sheet CSDL có thể lọc được?

.AutoFilter 10, Range("D8").Value

-Bạn không Autofilter được là do gán thuộc tính listfillRange của Combobox bằng name động. Khi có sự thay đổi trong sheet, name thay đổi, sự kiện Combobox_change bị kích hoạt. Trong code có dòng:

 With S1.Range(S1.[a2], S1.[a65000].End(3)).Offset(1).Resize(, 20)
   .................
.AutoFilter

nên tình trạng AutoFilter bị thoát.
-Để khắc phục tình trạng này, bạn hãy dùng cách nạp list sau. Xóa ListfillRange, và thêm đoạn code sau vào sheet s14:

Private Sub ComboBox1_DropButtonClick()
S14.ComboBox1.List() = S3.Range("kimnh").Value
End Sub