Sửa dùm code lọc dữ liệu

Liên hệ QC
chapi.you

chapi.you

Thành viên mới
Tham gia
24/3/11
Bài viết
20
Được thích
8
Tôi có code này, làm mãi không được. Tôi đưa lên đây để nhờ các AC xem và sửa dùm cho đúng!
 

File đính kèm

  • Loc_dl.rar
    7.8 KB · Đọc: 74
chapi.you đã viết:
Tôi có code này, làm mãi không được. Tôi đưa lên đây để nhờ các AC xem và sửa dùm cho đúng!
Nhấp chuột vào đây để mở rộng...
Thủ như thế này xem
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$E$1" Then
    Application.ScreenUpdating = False
    With S1.Range(S1.[A1], S1.[a10000].End(3)).Resize(, 2)
        .AutoFilter 1, S2.[E1] & "*"
        .Offset(1, 0).Resize(, 2).SpecialCells(12).Copy S2.[A4]
        .AutoFilter
    End With
    End If
End Sub
Thân
 
chapi.you đã viết:
Tôi có code này, làm mãi không được. Tôi đưa lên đây để nhờ các AC xem và sửa dùm cho đúng!
Nhấp chuột vào đây để mở rộng...
Sai cả 1 "rổ" luôn
Cái này:
Mã: 
With S1.Range(S1.[A1], [COLOR=red][B]S1.[10000][/B][/COLOR].End(3)).Resize(, 2)
Cái màu đỏ là cái gì? Có phải muốn nói là S1.[A10000] hay không?
Còn cái này:
Mã: 
.AutoFilter 1, Left(S1.[A2:A10000], 2) = S2.[E1]
Cái thằng VBA mà nó hiểu bạn nói gì chết liền
Nhưng tôi hơi... hiểu hiểu ---> Chắc là vầy:
Mã: 
.AutoFilter 1, Target.Value & "*"
Mấy vụ này nếu không biết thì có thể Record macro sao bạn không chịu thử nhỉ?
Làm lại:
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
  On Error GoTo ExitSub
  If Target.Address = "$E$1" Then
    Range("A3:B10000").Clear
    With S1.Range(S1.[A1], S1.[A10000].End(xlUp)).Resize(, 2)
      .AutoFilter 1, Target.Value & "*"
      .SpecialCells(12).Copy S2.[A3]
      .AutoFilter
    End With
  End If
ExitSub:
End Sub
 
Chỉ bạn dùng Advanced Filter cho bài này, code sẽ gọn hơn
Đầu tiên bố trí lại dữ liệu, chọn Validaiton xuống cell E2, còn cell E1 gõ chữ "Mã hàng"

untitled.JPG


Code rút gọn thành vầy:
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$E$2" Then
    Range("A3:B10000").Clear
    S1.Range("A1").CurrentRegion.AdvancedFilter 2, [E1:E2], [A3]
  End If
End Sub
-----------------------------
Nói thêm: Với dữ liệu cở vài chục ngàn dòng, nếu bạn dùng AutoFilter để lọc, sau đó dùng SpecialCells thì chắc chắn có lúc code bị lỗi (SpecialCells bị quá tải)... Dùng Advanced Filter lại không gặp hiện tượng này vì nó copy trực tiếp luôn
 

File đính kèm

  • Loc_dl.xls
    25.5 KB · Đọc: 118
Lần chỉnh sửa cuối:
ndu96081631 đã viết:
Chỉ bạn dùng Advanced Filter cho bài này, code sẽ gọn hơn
Đầu tiên bố trí lại dữ liệu, chọn Validaiton xuống cell E2, còn cell E1 gõ chữ "Mã hàng"

View attachment 60451


Code rút gọn thành vầy:
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$E$2" Then
    Range("A3:B10000").Clear
    S1.Range("A1").CurrentRegion.AdvancedFilter 2, [E1:E2], [A3]
  End If
End Sub
-----------------------------
Nói thêm: Với dữ liệu cở vài chục ngàn dòng, nếu bạn dùng AutoFilter để lọc, sau đó dùng SpecialCells thì chắc chắn có lúc code bị lỗi (SpecialCells bị quá tải)... Dùng Advanced Filter lại không gặp hiện tượng này vì nó copy trực tiếp luôn
Nhấp chuột vào đây để mở rộng...

Rất tuyệt vời em cảm ơn bác, bác có thể nâng cấp tiếp được không, em thấy có 2 vấn đề:

Ở code lọc này chỉ lọc các chữ cái tính từ trái sang phải, nhưng có thể lọc cho dù chữ cái đó ở bất kỳ vị trí nào trong mã không anh. ví dụ có 2 mã Hung, Hang cùng có chữ n khi em đánh chữ n thì nó lấy cả 2 vì cùng có chữ n ở vị trí bất kỳ. Tiếp đến nếu mã mà là số thì cái này không chạy
Chân thành cảm ơn anh
 
nmh_phocu đã viết:
Rất tuyệt vời em cảm ơn bác, bác có thể nâng cấp tiếp được không, em thấy có 2 vấn đề:

Ở code lọc này chỉ lọc các chữ cái tính từ trái sang phải, nhưng có thể lọc cho dù chữ cái đó ở bất kỳ vị trí nào trong mã không anh. ví dụ có 2 mã Hung, Hang cùng có chữ n khi em đánh chữ n thì nó lấy cả 2 vì cùng có chữ n ở vị trí bất kỳ. Tiếp đến nếu mã mà là số thì cái này không chạy
Chân thành cảm ơn anh
Nhấp chuột vào đây để mở rộng...

Đưa dữ liệu của bạn lên đi cho dễ hình dung... Nhưng tôi xin nói sơ qua về điều kiện trong Advanced Filter:
- Lọc điều kiện chuổi: Có thể dùng ký tự đại diện như * hoặc ?
- Lọc điều kiện là số: Có thể dùng các toán tự so sánh như >, <, >=, <= và =
 
Mọi người giúp viết dùm code lọc dữ liệu này với xin cảm ơn
Cột TT tự động tính.
 

File đính kèm

  • LOC DU LIEU.rar
    16.3 KB · Đọc: 11
Lần chỉnh sửa cuối:
Xuân hiếu đã viết:
Code của bạn làm gần đúng ý mình, nếu trường hợp như file mình bạn xem cái đường viền ở giữa cột BC, cột KL, MN mình muốn không tô viền thì làm bằng cách nào
Nhấp chuột vào đây để mở rộng...
Bạn thêm vào cuối code
Range("B7:C1000,K7:L1000,M7:N1000").Select
Selection.Borders(xlInsideVertical).LineStyle = xlNone
chắc là được .
 
Sửa lại code trên chút xíu sẽ được

Mã: 
Public Sub LOC_GPE()
Application.ScreenUpdating = False
Dim sArr(), dArr(), tArr(), I As Long, J As Long, K As Long, DK As String
With Sheets("DATA")
    sArr = .Range(.[B7], .[B65536].End(xlUp)).Resize(, 61).Value2
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 15)
With Sheets("LOC")
    tArr = .[A5:O5].Value2
    DK = .[J1].Value2
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 50) = DK Then
            K = K + 1: dArr(K, 1) = K
            For J = 2 To 15
                dArr(K, J) = sArr(I, tArr(1, J))
            Next J
        End If
    Next I
    With .[A7].Resize(1000, 15)
    .ClearContents
    .Borders.LineStyle = xlNone
    End With
    If K Then
        With .[A7].Resize(K, 15)
            .Value = dArr
            .Borders.LineStyle = xlContinuous
        End With
        With Union(.[B7].Resize(K, 2), .[K7].Resize(K, 2))
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            .Borders(xlInsideVertical).LineStyle = xlNone
            .Borders(xlInsideHorizontal).LineStyle = xlNone
        End With
        With .[M7].Resize(K, 2)
            .Borders(xlInsideVertical).LineStyle = xlNone
            .Borders(xlInsideHorizontal).LineStyle = xlNone
        End With
    End If
End With
Application.ScreenUpdating = True
End Sub
 
nmhung49 đã viết:
Sửa lại code trên chút xíu sẽ được

Mã: 
Public Sub LOC_GPE()
Application.ScreenUpdating = False
Dim sArr(), dArr(), tArr(), I As Long, J As Long, K As Long, DK As String
With Sheets("DATA")
    sArr = .Range(.[B7], .[B65536].End(xlUp)).Resize(, 61).Value2
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 15)
With Sheets("LOC")
    tArr = .[A5:O5].Value2
    DK = .[J1].Value2
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 50) = DK Then
            K = K + 1: dArr(K, 1) = K
            For J = 2 To 15
                dArr(K, J) = sArr(I, tArr(1, J))
            Next J
        End If
    Next I
    With .[A7].Resize(1000, 15)
    .ClearContents
    .Borders.LineStyle = xlNone
    End With
    If K Then
        With .[A7].Resize(K, 15)
            .Value = dArr
            .Borders.LineStyle = xlContinuous
        End With
        With Union(.[B7].Resize(K, 2), .[K7].Resize(K, 2))
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            .Borders(xlInsideVertical).LineStyle = xlNone
            .Borders(xlInsideHorizontal).LineStyle = xlNone
        End With
        With .[M7].Resize(K, 2)
            .Borders(xlInsideVertical).LineStyle = xlNone
            .Borders(xlInsideHorizontal).LineStyle = xlNone
        End With
    End If
End With
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...

CODE này chưa đúng lắm bạn xem giúp khung viền giống như trong file mình gửi kèm cảm ơn
 

File đính kèm

  • LOC DU LIEU.rar
    20 KB · Đọc: 16
Xuân hiếu đã viết:
CODE này chưa đúng lắm bạn xem giúp khung viền giống như trong file mình gửi kèm cảm ơn
Nhấp chuột vào đây để mở rộng...
Vậy thì lấy code này:
Thêm của xuan.nguyen82 một chút.
PHP: 
Public Sub LOC_GPE()
Application.ScreenUpdating = False
Dim sArr(), dArr(), tArr(), I As Long, J As Long, K As Long, DK As String
With Sheets("DATA")
    sArr = .Range(.[B7], .[B65536].End(xlUp)).Resize(, 61).Value2
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 15)
With Sheets("LOC")
    tArr = .[A5:O5].Value2
    DK = .[J1].Value2
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 50) = DK Then
            K = K + 1: dArr(K, 1) = K
            For J = 2 To 15
                dArr(K, J) = sArr(I, tArr(1, J))
            Next J
        End If
    Next I
    .[A7].Resize(1000, 15).ClearContents
    .[A7].Resize(1000, 15).Borders.LineStyle = xlNone
    If K Then
        With .[A7].Resize(K, 15)
        .Value = dArr
        .Borders.LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).Weight = xlHairline
        End With
        .[B7].Resize(K, 2).Borders(xlInsideVertical).LineStyle = xlNone
        .[K7].Resize(K, 2).Borders(xlInsideVertical).LineStyle = xlNone
        .[M7].Resize(K, 2).Borders(xlInsideVertical).LineStyle = xlNone
    End If
End With
Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

LuuAnh980
Vấn đề viết tắt trong Diễn Đàn.
    • Thích
    • Cười
2
Trả lời
25
Đọc
251
Phan Thế Hiệp
Phan Thế Hiệp
L
Tạo hàm Round cho nhiều dòng
Trả lời
14
Đọc
6K
KenJayce
K
N
Giải pháp nào để gỡ bỏ hàm Round (là hàm ngoài cùng) trong tất cả các ô trong bảng?
Trả lời
8
Đọc
4K
KenJayce
K
T
Tổng hợp từ Sheet1 qua Sheet2
Trả lời
7
Đọc
113
thaiquy7
T
ann266
Kế toán kho F&B
    • Cười
2
Trả lời
22
Đọc
247
le_vis
L
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom