Xin giúp code lọc và trích dữ liệu (1 người xem)

[mickeybh]

File mình gửi đính kèm có 3sh, sh dulieu chứa dữ liệu nguồn để lọc, sh trichloc để đưa dữ liệu lọc theo nhóm và chèn vào từng nhóm có sẵn, sh nhomloc gồm có 6 nhóm, mỗi nhóm có 1 hoặc nhiều mã điều kiện lọc (2 ký tự đầu của cột Mã thẻ BHYT bên sh dulieu.
Ví dụ lọc nhóm 1 với các điều kiện là CH or HC or HD or XK được 10 dòng thì sẽ copy 10 dòng đó và chèn vào dưới chữ nhóm I trong sh trichloc, tương tự cho các nhóm còn lại. Cấu trúc sheét dulieu va sheets trichloc hoàn toàn giống nhau.
Mong các bạn code giúp mình chứ ngồi lọc từng nhóm rồi dán vào thì hơi bị lâu.
Cảm ơn các bạn nhiều!
Phiền các bạn download theo link bên dưới chứ mình attach file cứ bị lỗi không được.
http://www.mediafire.com/?ph1vod3rxtqhwp7

 

[mickeybh]

Mình có post bài sai chuyên mục không nhỉ? Mấy hôm rồi không thấy 1 dòng hồi âm

 

[sealand]

Bạn thử kiểm tra xem có ổn không

Sub Filt()
Dim FCode(), Arr(1 To 60000, 1 To 23), Tm, Cl As Range
Dim i, j, Dg, Vt(), Tg(5, 3), n
Application.ScreenUpdating = False
Sheet2.Rows("13:65536").Delete
'Exit Sub
FCode = Array("HC,CH,HD,XK", "HT,BT,MS,XB,CC,CK,CB,TC,TQ,TA", "CN,HN", "TE,GKS", "HS", "XV,GD")
Vt = Array(" I", " II", " III", " IV", " V", " VI")
Tm = Sheet1.Range("A11:W" & Sheet1.[A65536].End(3).Row)
For n = 0 To 5
Dg = 0
For i = 1 To UBound(Tm, 1)
If InStr(1, FCode(n), Left(Trim(Tm(i, 5)), 2)) > 0 And Tm(i, 5) <> "" Then
Dg = Dg + 1
Arr(Dg, 1) = Dg
For j = 2 To UBound(Arr, 2)
Arr(Dg, j) = Tm(i, j)
Next
Tg(n, 0) = Tg(n, 0) + Tm(i, 11)
Tg(n, 1) = Tg(n, 1) + Tm(i, 18)
Tg(n, 2) = Tg(n, 2) + Tm(i, 20)
Tg(n, 3) = Tg(n, 0) + Tm(i, 22)
End If
Next
Set Cl = Sheet2.[B65536].End(3).Offset(1, -1)
Cl.Resize(Dg, 23) = Arr
Temp.Range("A20:W20").Copy
Cl.Resize(Dg, 23).PasteSpecial Paste:=xlPasteFormats
Temp.Cells(n + 13, 1).Resize(, 23).Copy Cl.Offset(Dg)
Cl.Offset(-1, 10) = Tg(n, 0)
Cl.Offset(-1, 17) = Tg(n, 1)
Cl.Offset(-1, 19) = Tg(n, 2)
Cl.Offset(-1, 21) = Tg(n, 3)
Next
Cl.Offset(Dg, 10) = Tg(0, 0) + Tg(1, 0) + Tg(2, 0) + Tg(3, 0) + Tg(4, 0) + Tg(5, 0)
Cl.Offset(Dg, 17) = Tg(0, 1) + Tg(1, 1) + Tg(2, 1) + Tg(3, 1) + Tg(4, 1) + Tg(5, 1)
Cl.Offset(Dg, 19) = Tg(0, 2) + Tg(1, 2) + Tg(2, 2) + Tg(3, 2) + Tg(4, 2) + Tg(5, 2)
Cl.Offset(Dg, 21) = Tg(0, 3) + Tg(1, 3) + Tg(2, 3) + Tg(3, 3) + Tg(4, 3) + Tg(5, 3)
Temp.Range("A19:W45").Copy Cl.Offset(Dg + 1)
Application.ScreenUpdating = True
Sheet2.[A1].Select
End Sub

http://www.mediafire.com/download/j8o4k1sycjd3ude/Trich_Loc.rar

 

[mickeybh]

Cảm ơn anh sealand!
Mấy hôm nay em chưa chạy thử được nên chưa có phản hồi.
- Ở cột mã thẻ nếu 2 ký tự đầu không viết hoa thì nó bỏ qua, có cách nào lọc luôn cả chữ hoa và chữ thường không anh hay em phải xử lý qua hàm upper trước khi chạy code?
- Ở cột số tiền sau khi lọc không đúng với kết quả trước khi lọc, anh xem lại dùm em với.

 

[tkchung]

Các bác cho em hỏi các bác làm việc trong lĩnh vực gì mà nhu cầu excel lại cần cả code thế ạ. Em làm kế toán nhưng excel chủ yếu dùng hàm. Đôi khi thấy nó không đáp ứng được nhu cầu công việc nhưng không biết học thế nào và phát triên kiến thức ra sao. mong các bác chỉ giáo...