Lọc dữ liệu duy nhất, đếm số lần xuất hiện và tính tổng của dữ liệu được lọc (19 người xem)

Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
baquang1984

baquang1984

Thành viên tiêu biểu
Tham gia
3/6/10
Bài viết
429
Được thích
44
Nghề nghiệp
Kỹ sư Lâm nghiệp
Em nhờ thầy, cô, các anh, chị và các bạn trên diễn đàn viết giúp Code VBA lọc dữ liệu, với yêu cầu của chương trình như sau:
- Em có Sheets"DATA" là sheets chứa dữ liệu lọc và lọc theo số CMND1, Sheets"TONGHOP" là Sheets kết quả của dữ liệu lọc sang theo thứ tự các cột như file đính kèm.
- Khi lọc dữ liệu sang Sheets"TONGHOP" thì các cột từ CQL đến cột Noi_cap2 là dữ liệu duy nhất, còn 3 cột
+ Cột Thua_dat đếm xem có bao nhiêu thửa ở số CMND1 (VD Số CMND1 080397392, CQL là ông Lộc Văn Biển ..... có 1 Thửa)
+ Cột To_BD đếm xem có bao nhiêu tờ bản đồ ở Số CMND1 (VD Số CMND1 080397392, CQL là ông Lộc Văn Biển ..... có 1 Tờ bản đồ)
+ Cột Dien_Tich tính tổng diện tích của các thửa tìm được ở Số CMND1 (VD Số CMND1 080397392, CQL là ông Lộc Văn Biển ..... Diện tích 174,8)
Trên đây là mô tả về điều kiện của chương trình lọc, hoặc kết quả đã được thể hiện trong file đính kèm.
Mong được mọi người giúp đỡ
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Ba Tê đã viết:
Trong các cột 12 -> 17 làm gì có thửa, hay Tờ BĐ. Bạn chọn 1 ô trong đó rồi nhìn trên thanh công thức xem, code chỉ ghi ra các con số thôi.
Chuyện khác vào Format Cells mà chỉnh. Bạn muốn con số 9 trong ô nhưng khi hiện trên màn hình là "vàng bốn số 9" cũng được mà.
Híc!
Nhấp chuột vào đây để mở rộng...
Vâng em cảm ơn anh, em tìm mãi mà không được, là do bác định dạng trong Format Cells. Trình độ sử dụng excel của em còn gà quá
 
Upvote 0
be09 đã viết:
Bạn cần tham khảo thêm cách tôi làm với File đính kèm ở bài #23 của Topic sau để hiểu thêm về những cái cần tổng hợp và nêu thêm cần tổng hợp những cái gì (ví dụ: tổng hợp diện tích cấp giấy với từng bản theo loại đất, với tổng thửa và tổng diện tích hoặc tổng hợp theo từng tờ bản đồ..v...v.....)? Tôi rảnh sẽ làm giúp cho bạn hoàn chỉnh sau.

http://www.giaiphapexcel.com/forum/...n-trợ-giúp-về-thống-kê-và-lọc-dữ-liệu-!/page3
Nhấp chuột vào đây để mở rộng...
Chương trình của anh hay quá, cách bố trí các trang tính như thế này tiện trong công tác thao tạc với dữ liệu và di chuyển nhanh giữa các Sheets.
thật là khoa học. Diễn đàn quả là nhiều các bậc tiền bối!
Em cảm ơn anh đã giúp đỡ, em chúc anh và gia đình sức khỏe!
 
Lần chỉnh sửa cuối:
Upvote 0
Em xin mạn phép tham gia với Code của anh BaTe và chủ Topic:

1/Để có thể linh hoạt trong việc đếm số thửa, số tờ bản đồ khi dữ liệu thục tế có thể rất động về cách viết (Ví dụ 45+46 hay 45/46 hay 45&46 v.v...Cũng như loại bỏ việc đếm nhầm các dấu nối ở đầu hay cuối như +55 chẳng hạn) và có thể sử dụng nhiều lần (Vì co tới 4 cột áp dụng cách đếm này) ta nên xây dựng 1 hàm Thư viện như sau:

Mã: 
Function MCount(ByVal Vl As String) As Integer
Dim Kt As Boolean, StrTest As String, Tm, x
Vl = Trim(Vl)
StrTest = "+~/~\~-~;~,~.~*~&~^~%"
Do
If Vl = "" Then
Exit Function
ElseIf InStr(1, StrTest, Left(Vl, 1)) > 0 Then
Vl = Right(Vl, Len(Vl) - 1)
ElseIf InStr(1, Right(Vl, 1)) > 0 Then
Vl = Left(Vl, Len(Vl) - 1)
Else
Kt = True
End If
Loop Until Kt
Tm = Split(StrTest, "~")
For x = LBound(Tm) To UBound(Tm)
If InStr(1, Vl, Tm(x)) > 0 Then
MCount = MCount + Len(Vl) - Len(Replace(Vl, Tm(x), ""))
End If
Next
MCount = MCount + 1
End Function

2/Trong Code chính nên viết cho gọn dễ kiểm soát hơn, mệnh đề With...end with chẳng hạn. Chỉ vì tránh 3 chỗ viết tên Sheet mà lại thêm 2 dòng lệnh. Biến Tem cũng vậy, nếu dùng ít ta gán luôn khỏi dùng biến trung gian.
Với Hàm trên em xin phép Modify Code của bác như sau:

Mã: 
Sub GPExyz()
Dim Dic As Object, sArr(), dArr(), Col(), I As Long, J As Long, K As Long, GPE, Id
Dim DKThon As String, DKMa As Long
Set Dic = CreateObject("Scripting.Dictionary")
DKThon = UCase(Sheets("TONGHOP").[B2])
DKMa = Sheets("TONGHOP").[E2].Value
    sArr = Sheets("Data").Range(Sheets("Data").[A3], Sheets("Data").[A3].End(xlDown)).Resize(, 44).Value
For I = 1 To UBound(sArr, 1)
  [COLOR=#008080][I]'Kiem tra neu dung Thon va CMND thi thuc hien 2 viec sau[/I][/COLOR]
    If UCase(sArr(I, 3)) = DKThon And sArr(I, 44) = DKMa Then
           [COLOR=#008080][I] 'Neu trong Danh sach chua co thi Bo xung vao Danh sach[/I][/COLOR]
            If Not Dic.Exists(sArr(I, 5)) Then
            K = K + 1
            Dic.Add sArr(I, 5), K
            ReDim Preserve dArr(1 To 17, 1 To K)
            For J = 1 To 11
            dArr(J, K) = sArr(I, J + 1)
            Next
            End If
            [I][COLOR=#008080]'Tong hop du lieu vao Danh sach[/COLOR][/I]
            Id = Dic.Item(sArr(I, 5))
            dArr(12, Id) = dArr(12, Id) + MCount(sArr(I, 13))
            dArr(13, Id) = dArr(13, Id) + MCount(sArr(I, 14))
            dArr(14, Id) = dArr(14, Id) + sArr(I, 15)
            dArr(15, Id) = dArr(15, Id) + MCount(sArr(I, 28))
            dArr(16, Id) = dArr(16, Id) + MCount(sArr(I, 29))
            dArr(17, Id) = dArr(17, Id) + sArr(I, 30)
    End If
  Next
With Sheets("TONGHOP")
    .[A5:A1000].Resize(, 17).ClearContents
    If K Then .[A5].Resize(K, 17).Value = WorksheetFunction.Transpose(dArr)
End With
End Sub

Như vậy, Code của bác giờ gọn gàng và dễ kiểm soát hơn nhiều.(Em chưa Test nhưng có thể tốc độ cũng cao hơn)
Bác BaTe thông cảm nha
 
Lần chỉnh sửa cuối:
Upvote 0
sealand đã viết:
Em xin mạn phép tham gia với Code của anh BaTe và chủ Topic:

1/Để có thể linh hoạt trong việc đếm số thửa, số tờ bản đồ khi dữ liệu thục tế có thể rất động về cách viết (Ví dụ 45+46 hay 45/46 hay 45&46 v.v...Cũng như loại bỏ việc đếm nhầm các dấu nối ở đầu hay cuối như +55 chẳng hạn) và có thể sử dụng nhiều lần (Vì co tới 4 cột áp dụng cách đếm này) ta nên xây dựng 1 hàm Thư viện như sau:

Mã: 
Function MCount(ByVal Vl As String) As Integer
Dim Kt As Boolean, StrTest As String, Tm, x
Vl = Trim(Vl)
StrTest = "+~/~\~-~;~,~.~*~&~^~%"
Do
If Vl = "" Then
Exit Function
ElseIf InStr(1, StrTest, Left(Vl, 1)) > 0 Then
Vl = Right(Vl, Len(Vl) - 1)
ElseIf InStr(1, Right(Vl, 1)) > 0 Then
Vl = Left(Vl, Len(Vl) - 1)
Else
Kt = True
End If
Loop Until Kt
Tm = Split(StrTest, "~")
For x = LBound(Tm) To UBound(Tm)
If InStr(1, Vl, Tm(x)) > 0 Then
MCount = MCount + Len(Vl) - Len(Replace(Vl, Tm(x), ""))
End If
Next
MCount = MCount + 1
End Function

2/Trong Code chính nên viết cho gọn dễ kiểm soát hơn, mệnh đề With...end with chẳng hạn. Chỉ vì tránh 3 chỗ viết tên Sheet mà lại thêm 2 dòng lệnh. Biến Tem cũng vậy, nếu dùng ít ta gán luôn khỏi dùng biến trung gian.
Với Hàm trên em xin phép Modify Code của bác như sau:

Mã: 
Sub GPExyz()
Dim Dic As Object, sArr(), dArr(), Col(), I As Long, J As Long, K As Long, GPE, Id
Dim DKThon As String, DKMa As Long
Set Dic = CreateObject("Scripting.Dictionary")
DKThon = UCase(Sheets("TONGHOP").[B2])
DKMa = Sheets("TONGHOP").[E2].Value
    sArr = Sheets("Data").Range(Sheets("Data").[A3], Sheets("Data").[A3].End(xlDown)).Resize(, 44).Value
For I = 1 To UBound(sArr, 1)
  [COLOR=#008080][I]'Kiem tra neu dung Thon va CMND thi thuc hien 2 viec sau[/I][/COLOR]
    If UCase(sArr(I, 3)) = DKThon And sArr(I, 44) = DKMa Then
           [COLOR=#008080][I] 'Neu trong Danh sach chua co thi Bo xung vao Danh sach[/I][/COLOR]
            If Not Dic.Exists(sArr(I, 5)) Then
            K = K + 1
            Dic.Add sArr(I, 5), K
            ReDim Preserve dArr(1 To 17, 1 To K)
            For J = 1 To 11
            dArr(J, K) = sArr(I, J + 1)
            Next
            End If
            [I][COLOR=#008080]'Tong hop du lieu vao Danh sach[/COLOR][/I]
            Id = Dic.Item(sArr(I, 5))
            dArr(12, Id) = dArr(12, Id) + MCount(sArr(I, 13))
            dArr(13, Id) = dArr(13, Id) + MCount(sArr(I, 14))
            dArr(14, Id) = dArr(14, Id) + sArr(I, 15)
            dArr(15, Id) = dArr(15, Id) + MCount(sArr(I, 28))
            dArr(16, Id) = dArr(16, Id) + MCount(sArr(I, 29))
            dArr(17, Id) = dArr(17, Id) + sArr(I, 30)
    End If
  Next
With Sheets("TONGHOP")
    .[A5:A1000].Resize(, 17).ClearContents
    If K Then .[A5].Resize(K, 17).Value = WorksheetFunction.Transpose(dArr)
End With
End Sub

Như vậy, Code của bác giờ gọn gàng và dễ kiểm soát hơn nhiều.(Em chưa Test nhưng có thể tốc độ cũng cao hơn)
Bác BaTe thông cảm nha
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh vậy để áp dụng hàm thư viện của anh vào với code của bác góp ý thì dùng thế nào ạ
 
Upvote 0
Thì cứ chép chung nó vào 1 Module là OK
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Ba Tê đã viết:
Thấy còn "đèn" cũng ráng sửa một chút xem sao. Hổng trúng thì mai tiếp, hổng chơi nữa à nghe.
Nhấp chuột vào đây để mở rộng...
Anh Ba Tê và các thành viên trên diễn đàn cho em làm phiển các thành viên thêm chút nữa là
Khi lọc dữ liệu sang Sheets"TONGHOP" thì dữ liệu tại các cột 12, 13 và 15, 16, 18, 19, 20 dữ liệu sẽ được ghi ra như sau ạ:
- Nếu Chủ quản lý nào (CMND1) có 1 thửa ở cột 12 Sheets"TONGHOP" thì Cột 12 sẽ ghi luôn số thửa tìm được, cột 13 ghi luôn số tờ bản đồ tìm được bên Sheets"DATA".
- Nếu Chủ quản lý nào (CMND1) có 2 thửa trở lên ở cột 12 Sheets"TONGHOP" thì Cột 12 sẽ ghi số thửa đếm được + chữ "thửa" (VD 2 thửa), cột 13 ghi số tờ bản đồ đếm được + chữ "tờ bản đồ" (VD 1 tờ bản đồ)
- Nếu Chủ quản lý nào (CMND1) có 1 thửa ở cột 16 Sheets"TONGHOP" thì Cột 16 sẽ ghi luôn số thửa tìm được, cột 15 ghi luôn số tờ bản đồ tìm được, cột 18 ghi SO_GCNcu, cột 19 ghi NGAY_CAPcu, cột 20 ghi MDSDcu với dữ liệu tìm được tại các cột 28, 29, 31, 32, 33 bên Sheets"DATA"
- Nếu chủ quản lý nào (CMND1) cột 16 Sheets"TONGHOP" có 2 thửa trở lên thì Cột 16 sẽ ghi số thửa đếm được + chữ "thửa" (VD 2 thửa), cột 15 ghi số tờ bản đồ đếm được + chữ "tờ bản đồ" (VD 1 tờ bản đồ) còn các cột 18, 19, 20 không thể hiện thông tin
giúp em thêm lấy thông tin vào 2 cột giới tính 1, giới tính 2 Sheets"TONGHOP"
Em cảm ơn anh và các thành viên của diễn đàn!
 

File đính kèm

Upvote 0
Bạn thay Code này vào Code cũ:

Mã: 
Sub GPExyz()
Dim Dic As Object, sArr(), dArr(), Col(), I As Long, J As Long, k As Long, GPE, Id
Dim DKThon As String, DKMa As Long
Set Dic = CreateObject("Scripting.Dictionary")
DKThon = UCase(Sheets("TONGHOP").[B2])
DKMa = Sheets("TONGHOP").[E2].Value
    sArr = Sheets("Data").Range(Sheets("Data").[A3], Sheets("Data").[A3].End(xlDown)).Resize(, 44).Value
For I = 1 To UBound(sArr, 1)
    'Kiem tra neu dung Thon va CMND thi thuc hien 2 viec sau
    If UCase(sArr(I, 3)) = DKThon And sArr(I, 44) = DKMa Then
            'Neu trong Danh sach chua co thi Bo xung vao Danh sach
            If Not Dic.Exists(sArr(I, 5)) Then
            k = k + 1
            Dic.Add sArr(I, 5), k
            ReDim Preserve dArr(1 To 17, 1 To k)
            For J = 1 To 11
            dArr(J, k) = sArr(I, J + 1)
            Next
            End If
            'Tong hop du lieu vao Danh sach
            Id = Dic.Item(sArr(I, 5))
            dArr(12, Id) = dArr(12, Id) & IIf(dArr(12, Id) <> "", "+", "") & sArr(I, 13)
            dArr(13, Id) = dArr(13, Id) & IIf(dArr(13, Id) <> "", "+", "") & sArr(I, 14)
            dArr(14, Id) = dArr(14, Id) + sArr(I, 15)
            dArr(15, Id) = dArr(15, Id) & IIf(dArr(15, Id) <> "", "+", "") & sArr(I, 28)
            dArr(16, Id) = dArr(16, Id) & IIf(dArr(16, Id) <> "", "+", "") & sArr(I, 29)
            dArr(17, Id) = dArr(17, Id) + sArr(I, 30)
    End If
  Next
  For I = 1 To UBound(dArr, 2)
  dArr(12, I) = IIf(MCount(dArr(12, I)) = 1, "Th" & ChrW(7917) & "a s" & ChrW(7889) & ":  " & dArr(12, I), _
  IIf(MCount(dArr(12, I)) = 0, "", "C" & ChrW(7897) & "ng th" & ChrW(7917) & "a: " & MCount(dArr(12, I))))
  
  dArr(13, I) = IIf(MCount(dArr(13, I)) = 1, "B" & ChrW(7843) & "n " & ChrW(273) & ChrW(7891) & " s" & ChrW(7889) & ": " & dArr(13, I), _
  IIf(MCount(dArr(13, I)) = 0, "", "S" & ChrW(7889) & " t" & ChrW(7901) & " BD: " & MCount(dArr(13, I))))
  
  dArr(15, I) = IIf(MCount(dArr(15, I)) = 1, "B" & ChrW(7843) & "n " & ChrW(273) & ChrW(7891) & " s" & ChrW(7889) & ": " & dArr(15, I), _
  IIf(MCount(dArr(15, I)) = 0, "", "S" & ChrW(7889) & " t" & ChrW(7901) & " BD: " & MCount(dArr(15, I))))
  
  dArr(16, I) = IIf(MCount(dArr(16, I)) = 1, "Th" & ChrW(7917) & "a s" & ChrW(7889) & ": " & dArr(16, I), _
  IIf(MCount(dArr(16, I)) = 0, "", "C" & ChrW(7897) & "ng th" & ChrW(7917) & "a: " & MCount(dArr(16, I))))
  Next
  
With Sheets("TONGHOP")
    .[A5:A1000].Resize(, 17).ClearContents
    If k Then .[A5].Resize(k, 17).Value = WorksheetFunction.Transpose(dArr)
End With
End Sub
 
Upvote 0
Mình kiểm tra lại và code như sau mới đúng yêu cầu của bạn

Mã: 
Sub GPExyz()
Dim Dic As Object, sArr(), dArr(), Col(), I As Long, J As Long, k As Long, GPE, Id
Dim DKThon As String, DKMa As Long
................................................................
  For I = 1 To UBound(dArr, 2)
  dArr(12, I) = IIf(MCount(dArr(12, I)) = 1, dArr(12, I), _
  IIf(MCount(dArr(12, I)) = 0, "", MCount(dArr(12, I)) & " th" & ChrW(7917) & "a"))
  
  dArr(13, I) = IIf(MCount(dArr(13, I)) = 1, dArr(13, I), _
  IIf(MCount(dArr(13, I)) = 0, "", MCount(dArr(13, I)) & " t" & ChrW(7901) & " b" & ChrW(7843) & "n " & ChrW(273) & ChrW(7891)))
  
  dArr(15, I) = IIf(MCount(dArr(15, I)) = 1, dArr(15, I), _
  IIf(MCount(dArr(15, I)) = 0, "", MCount(dArr(15, I)) & " t" & ChrW(7901) & " b" & ChrW(7843) & "n " & ChrW(273) & ChrW(7891)))
  
  dArr(16, I) = IIf(MCount(dArr(16, I)) = 1, dArr(16, I), _
  IIf(MCount(dArr(16, I)) = 0, "", MCount(dArr(16, I)) & " th" & ChrW(7917) & "a"))
  Next
.................................................
End Sub
 
Upvote 0
sealand đã viết:
Mình kiểm tra lại và code như sau mới đúng yêu cầu của bạn

Mã: 
Sub GPExyz()
Dim Dic As Object, sArr(), dArr(), Col(), I As Long, J As Long, k As Long, GPE, Id
Dim DKThon As String, DKMa As Long
................................................................
  For I = 1 To UBound(dArr, 2)
  dArr(12, I) = IIf(MCount(dArr(12, I)) = 1, dArr(12, I), _
  IIf(MCount(dArr(12, I)) = 0, "", MCount(dArr(12, I)) & " th" & ChrW(7917) & "a"))
  
  dArr(13, I) = IIf(MCount(dArr(13, I)) = 1, dArr(13, I), _
  IIf(MCount(dArr(13, I)) = 0, "", MCount(dArr(13, I)) & " t" & ChrW(7901) & " b" & ChrW(7843) & "n " & ChrW(273) & ChrW(7891)))
  
  dArr(15, I) = IIf(MCount(dArr(15, I)) = 1, dArr(15, I), _
  IIf(MCount(dArr(15, I)) = 0, "", MCount(dArr(15, I)) & " t" & ChrW(7901) & " b" & ChrW(7843) & "n " & ChrW(273) & ChrW(7891)))
  
  dArr(16, I) = IIf(MCount(dArr(16, I)) = 1, dArr(16, I), _
  IIf(MCount(dArr(16, I)) = 0, "", MCount(dArr(16, I)) & " th" & ChrW(7917) & "a"))
  Next
.................................................
End Sub
Nhấp chuột vào đây để mở rộng...
Em kiểm tra thì ở Cột 12, 13 và 15, 16 kết quản ra không được chuẩn anh ạ, chẳng hạn như em lọc Thôn Khuổi Phầy, Mã bằng 3
CQL Mã Ngọc Bằng ở Sheets"DATA" có số thửa ở cột 29 là 1 thửa (Thửa số 1) cột 28 không có tờ bản đồ, khi lọc sang Sheets"TONGHOP" thì cả 2 cột 15, 16 đều không có thông tin, đúng của yêu cầu chương trình ghi ở Côt 15 không ghi gì, cột 16 ghi số 1.
em lọc Thôn Khuổi Phầy, Mã bằng 2 thì CQL Mã Ngọc Bằng ở Sheets"DATA" có số thửa ở cột 13 là 4 thửa cột 14 có 2 tờ bản đồ là (Tờ số 5 và số 6), khi lọc sang Sheets"TONGHOP" thì cột 12 đúng 4 thửa, cột 13 chưa đúng, đúng yêu cầu của chương trình ghi ở Côt 12 ghi là 4 thửa, cột 13 ghi 2 tờ bản đồ.
Anh kiểm tra lại giúp em với ạ
Anh có thể cho hiển thị thông tin thêm cho em như em mô tả ở #46 được không anh. Còn các cột [TABLE="width: 464"]
[TR]
[TD="class: xl67, width: 86"]SO_GCNcu[/TD]
[TD="class: xl68, width: 107"]NGAY_CAPcu[/TD]
[TD="class: xl67, width: 71"]MDSDcu[/TD]
[TD="class: xl67, width: 100"]GIOI_TINH1[/TD]
[TD="class: xl67, width: 100"]GIOI_TINH2[/TD]
[/TR]
[/TABLE]
Em cảm ơn anh!
 
Lần chỉnh sửa cuối:
Upvote 0
baquang1984 đã viết:
Anh Ba Tê và các thành viên trên diễn đàn cho em làm phiển các thành viên thêm chút nữa là
Khi lọc dữ liệu sang Sheets"TONGHOP" thì dữ liệu tại các cột 12, 13 và 15, 16, 18, 19, 20 dữ liệu sẽ được ghi ra như sau ạ:
- Nếu Chủ quản lý nào (CMND1) có 1 thửa ở cột 12 Sheets"TONGHOP" thì Cột 12 sẽ ghi luôn số thửa tìm được, cột 13 ghi luôn số tờ bản đồ tìm được bên Sheets"DATA".
- Nếu Chủ quản lý nào (CMND1) có 2 thửa trở lên ở cột 12 Sheets"TONGHOP" thì Cột 12 sẽ ghi số thửa đếm được + chữ "thửa" (VD 2 thửa), cột 13 ghi số tờ bản đồ đếm được + chữ "tờ bản đồ" (VD 1 tờ bản đồ)
- Nếu Chủ quản lý nào (CMND1) có 1 thửa ở cột 16 Sheets"TONGHOP" thì Cột 16 sẽ ghi luôn số thửa tìm được, cột 15 ghi luôn số tờ bản đồ tìm được, cột 18 ghi SO_GCNcu, cột 19 ghi NGAY_CAPcu, cột 20 ghi MDSDcu với dữ liệu tìm được tại các cột 28, 29, 31, 32, 33 bên Sheets"DATA"
- Nếu chủ quản lý nào (CMND1) cột 16 Sheets"TONGHOP" có 2 thửa trở lên thì Cột 16 sẽ ghi số thửa đếm được + chữ "thửa" (VD 2 thửa), cột 15 ghi số tờ bản đồ đếm được + chữ "tờ bản đồ" (VD 1 tờ bản đồ) còn các cột 18, 19, 20 không thể hiện thông tin
giúp em thêm lấy thông tin vào 2 cột giới tính 1, giới tính 2 Sheets"TONGHOP"
Em cảm ơn anh và các thành viên của diễn đàn!
Nhấp chuột vào đây để mở rộng...
Đã lỡ có "dính" với topic này rồi, dù là code có "bèo nhèo", "nhăn nheo", không gọn gàng, khó chỉnh sửa.
HY vọng là xài tạm được.
Híc!
cho em làm phiển các thành viên thêm chút nữa
Nhấp chuột vào đây để mở rộng...
Hổng dám chút đâu! "Điếc con mắt" luôn.
 

File đính kèm

Upvote 0
Ba Tê đã viết:
Đã lỡ có "dính" với topic này rồi, dù là code có "bèo nhèo", "nhăn nheo", không gọn gàng, khó chỉnh sửa.
HY vọng là xài tạm được.
Híc!

Hổng dám chút đâu! "Điếc con mắt" luôn.
Nhấp chuột vào đây để mở rộng...
Hixxx bác vui tính quá với chương trình kiều như thế này thì đối với anh chỉ là chuyện nhỏ mà
Cảm ơn anh nhiều!
 
Upvote 0
Bạn bổ xung 1 dòng sau vào Hàm đếm nha

Mã: 
Function MCount(ByVal Vl As String) As Integer
Dim Kt As Boolean, StrTest As String, Tm, x
[B][COLOR=#ff0000]If IsNumeric(Vl) Then Vl = "m" & Vl[/COLOR][/B]
Vl = Trim(Vl)

StrTest = "+~/~\~-~;~,~.~*~&~^~%"
Do
If Vl = "" Then
Exit Function
ElseIf InStr(1, StrTest, Left(Vl, 1)) > 0 Then
Vl = Right(Vl, Len(Vl) - 1)
ElseIf InStr(1, Right(Vl, 1)) > 0 Then
Vl = Left(Vl, Len(Vl) - 1)
Else
Kt = True
End If
Loop Until Kt
Tm = Split(StrTest, "~")
For x = LBound(Tm) To UBound(Tm)
If InStr(1, Vl, Tm(x)) > 0 Then
MCount = MCount + Len(Vl) - Len(Replace(Vl, Tm(x), ""))
End If
Next
MCount = MCount + 1
End Function
 
Upvote 0
Ba Tê đã viết:
Đã lỡ có "dính" với topic này rồi, dù là code có "bèo nhèo", "nhăn nheo", không gọn gàng, khó chỉnh sửa.
HY vọng là xài tạm được.
Híc!

Hổng dám chút đâu! "Điếc con mắt" luôn.
Nhấp chuột vào đây để mở rộng...
Anh Ba Tê ạ không ổn anh ơi, khi em lọc dữ liệu sang Sheets"TONGHOP" thì ở cột 12 có 1 thửa thì không ghi thửa tim được bên Sheets"DATA" mà toàn ghi là 1 thôi hixx
Anh kiểm tra lại giúp em với ạ!
 
Upvote 0
sealand đã viết:
Bạn bổ xung 1 dòng sau vào Hàm đếm nha

Mã: 
Function MCount(ByVal Vl As String) As Integer
Dim Kt As Boolean, StrTest As String, Tm, x
[B][COLOR=#ff0000]If IsNumeric(Vl) Then Vl = "m" & Vl[/COLOR][/B]
Vl = Trim(Vl)

StrTest = "+~/~\~-~;~,~.~*~&~^~%"
Do
If Vl = "" Then
Exit Function
ElseIf InStr(1, StrTest, Left(Vl, 1)) > 0 Then
Vl = Right(Vl, Len(Vl) - 1)
ElseIf InStr(1, Right(Vl, 1)) > 0 Then
Vl = Left(Vl, Len(Vl) - 1)
Else
Kt = True
End If
Loop Until Kt
Tm = Split(StrTest, "~")
For x = LBound(Tm) To UBound(Tm)
If InStr(1, Vl, Tm(x)) > 0 Then
MCount = MCount + Len(Vl) - Len(Replace(Vl, Tm(x), ""))
End If
Next
MCount = MCount + 1
End Function
Nhấp chuột vào đây để mở rộng...
Phần này cũng chưa được anh ạ!
em lọc Thôn Khuổi Phầy, Mã bằng 2 thì CQL Mã Ngọc Bằng ở Sheets"DATA" có số thửa ở cột 13 là 4 thửa cột 14 có 2 tờ bản đồ là (Tờ số 5 và số 6), khi lọc sang Sheets"TONGHOP" thì cột 12 đúng 4 thửa, cột 13 chưa đúng, đúng yêu cầu của chương trình ghi ở Côt 12 ghi là 4 thửa, cột 13 ghi 2 tờ bản đồ.
Anh kiểm tra lại giúp em với ạ
Anh có thể cho hiển thị thông tin thêm cho em như em mô tả ở #46 được không anh. Còn các cột[TABLE="class: cms_table, width: 464"]
[TR]
[TD="class: cms_table_xl67, width: 86"]SO_GCNcu[/TD]
[TD="class: cms_table_xl68, width: 107"]NGAY_CAPcu[/TD]
[TD="class: cms_table_xl67, width: 71"]MDSDcu[/TD]
[TD="class: cms_table_xl67, width: 100"]GIOI_TINH1[/TD]
[TD="class: cms_table_xl67, width: 100"]GIOI_TINH2[/TD]
[/TR]
[/TABLE]

Em cảm ơn anh!
 
Upvote 0
baquang1984 đã viết:
Anh Ba Tê ạ không ổn anh ơi, khi em lọc dữ liệu sang Sheets"TONGHOP" thì ở cột 12 có 1 thửa thì không ghi thửa tim được bên Sheets"DATA" mà toàn ghi là 1 thôi hixx
Anh kiểm tra lại giúp em với ạ!
Nhấp chuột vào đây để mở rộng...
Cột 12 sai do chưa "giải quyết nó", Nhiều chuyện lu bu nên sót lại cột 12.
Tải file này về, chép 3 Sub trong Module thay cho tất cả các sub cũ.
Đưa ra đôi giày, "đẽo" riết rồi cái chân sưng vù mà chưa biết "nhét" vào chiếc giày đựợc không.
Híc!
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Ba Tê đã viết:
Cột 12 sai do chưa "giải quyết nó", Nhiều chuyện lu bu nên sót lại cột 12.
Tải file này về, chép 3 Sub trong Module thay cho tất cả các sub cũ.
Đưa ra đôi giày, "đẽo" riết rồi cái chân sưng vù mà chưa biết "nhét" vào chiếc giày đựợc không.
Híc!
Nhấp chuột vào đây để mở rộng...
Anh Ba Tê em kiêm tra chương trình thì ở cột 12, 13 và 15, 16 Sheets"TONGHOP" chưa được anh ạ,
Em lọc thôn Khuổi Phầy: Mã 1 kết quả cho như bảng sau
[TABLE="class: grid, width: 370, align: center"]
[TR]
[TD="align: center"]Thua_dat[/TD]
[TD="align: center"]To_BD[/TD]
[TD="align: center"]To_BDcu[/TD]
[TD="align: center"]THUA_DATcu[/TD]
[/TR]
[TR]
[TD="align: center"]13[/TD]
[TD="align: center"]14[/TD]
[TD="align: center"]28[/TD]
[TD="align: center"]29[/TD]
[/TR]
[TR]
[TD="align: center"]10 thửa[/TD]
[TD="align: center"]9[/TD]
[TD="align: center"]3 tờ bản đồ[/TD]
[TD="align: center"]10 thửa[/TD]
[/TR]
[TR]
[TD="align: center"]11 thửa[/TD]
[TD="align: center"]5 tờ bản đồ[/TD]
[TD="align: center"]3 tờ bản đồ[/TD]
[TD="align: center"]12 thửa[/TD]
[/TR]
[TR]
[TD="align: center"]6 thửa[/TD]
[TD="align: center"]2 tờ bản đồ[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]7 thửa[/TD]
[/TR]
[TR]
[TD="align: center"]12 thửa[/TD]
[TD="align: center"]3 tờ bản đồ[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]13 thửa[/TD]
[/TR]
[TR]
[TD="align: center"]5 thửa[/TD]
[TD="align: center"]2 tờ bản đồ[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]5 thửa[/TD]
[/TR]
[TR]
[TD="align: center"]4 thửa[/TD]
[TD="align: center"]6[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]5 thửa[/TD]
[/TR]
[TR]
[TD="align: center"]5 thửa[/TD]
[TD="align: center"]5[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]5 thửa[/TD]
[/TR]
[TR]
[TD="align: center"]60[/TD]
[TD="align: center"]6[/TD]
[TD="align: center"] [/TD]
[TD="align: center"] [/TD]
[/TR]
[/TABLE]
Yêu cầu của chương trình là:
ở cả 4 cột là 12, 13 và 15, 16 nếu 1 chủ quản lý ở Cột 12, 16 mà đếm được 1 thửa thì ghi số thửa tìm được bên Sheets"DATA", và ghi tờ bản đồ tìm được bên Sheets"DATA" đối với thửa cũ thì ghi thông tin ở các cột [TABLE="class: cms_table_cms_table, width: 464"]
[TR]
[TD="class: cms_table_cms_table_xl67, width: 86"]SO_GCNcu[/TD]
[TD="class: cms_table_cms_table_xl68, width: 107"]NGAY_CAPcu[/TD]
[TD="class: cms_table_cms_table_xl67, width: 71"]MDSDcu[/TD]
[/TR]
[/TABLE]
Nếu 1 chủ quản lý ở cột 12, 16 đếm được số thửa > 1 thì ghi là Số thửa đếm được + chữ "thửa", ghi số tờ bản đồ đếm được + chữ "tờ bản đồ" (VD một chủ quản lý co 5 thửa và cũng chỉ có 1 tờ bản đồ (là tờ số 5) thì ghi là 5 thửa ở cột 12, 1 tờ bản đồ ở cột 13 và ở cột 16 có 7 thửa và cũng chỉ có 1 tờ bản đồ (là tờ số 1) thì ghi là 7 thửa ở cột 16, 1 tờ bản đồ ở cột 15
Khi chạy chương trình lọc của anh viết thì ở phần em bôi màu xanh là chưa đúng ạ
Mong anh kiểm tra lại giúp em
em cảm ơn anh đã nhiệt tình giúp đỡ
 
Lần chỉnh sửa cuối:
Upvote 0
Để dáp ứng yêu cầu của bạn tôi xin điều chỉnh toàn bộ Code như sau:

Mã: 
Sub GPExyz()
Dim Dic As Object, sArr(), dArr(), Col(), i As Long, j As Long, k As Long, GPE, Id
Dim DKThon As String, DKMa As Long
Set Dic = CreateObject("Scripting.Dictionary")
DKThon = UCase(Sheets("TONGHOP").[B2])
DKMa = Sheets("TONGHOP").[E2].Value
    sArr = Sheets("Data").Range(Sheets("Data").[A3], Sheets("Data").[A3].End(xlDown)).Resize(, 44).Value
For i = 1 To UBound(sArr, 1)
    'Kiem tra neu dung Thon va CMND thi thuc hien 2 viec sau
    If UCase(sArr(i, 3)) = DKThon And sArr(i, 44) = DKMa Then
            'Neu trong Danh sach chua co thi Bo xung vao Danh sach
            If Not Dic.Exists(sArr(i, 5)) Then
            k = k + 1
            Dic.Add sArr(i, 5), k
            ReDim Preserve dArr(1 To 22, 1 To k)
            For j = 1 To 11
            dArr(j, k) = sArr(i, j + 1)
            Next
            dArr(21, k) = sArr(i, 26)
            dArr(22, k) = sArr(i, 27)
            End If
            'Tong hop du lieu vao Danh sach
            Id = Dic.Item(sArr(i, 5))
            dArr(12, Id) = JoinStr(dArr(12, Id), sArr(i, 13))
            dArr(13, Id) = JoinStr(dArr(13, Id), sArr(i, 14))
            dArr(14, Id) = dArr(14, Id) + sArr(i, 15)
            dArr(15, Id) = JoinStr(dArr(15, Id), sArr(i, 28))
            dArr(16, Id) = JoinStr(dArr(16, Id), sArr(i, 29))
            dArr(17, Id) = dArr(17, Id) + sArr(i, 30)
            If sArr(i, 31) <> "" Then dArr(18, Id) = JoinStr(dArr(18, Id), sArr(i, 31))
            If sArr(i, 32) <> "" Then dArr(19, Id) = JoinStr(dArr(19, Id), sArr(i, 32))
            If sArr(i, 33) <> "" Then dArr(20, Id) = JoinStr(dArr(20, Id), sArr(i, 33))
    End If
  Next
          For i = 1 To k
                dArr(12, i) = SetVl(dArr(12, i), True)
                dArr(13, i) = SetVl(dArr(13, i), False)
                dArr(15, i) = SetVl(dArr(15, i), False)
                dArr(16, i) = SetVl(dArr(16, i), True)
                dArr(18, i) = Replace(dArr(18, Id), "%", "  ")
                dArr(19, i) = Replace(dArr(19, Id), "%", "  ")
                dArr(20, i) = Replace(dArr(20, Id), "%", "  ")
         Next
With Sheets("TONGHOP")
    .[A5:A1000].Resize(, 22).ClearContents
    If k Then .[A5].Resize(k, 22).Value = WorksheetFunction.Transpose(dArr)
End With
End Sub
'==========================================================
Function JoinStr(ByVal Ch1 As String, ByVal Ch2 As String) As String
Dim Sp(), ch As String, i
Ch1 = Trim(Ch1): Ch2 = Trim(Ch2)
If InStr(1, Ch1, "%" & Ch2 & "%") > 0 Then
JoinStr = Ch1
Exit Function
Else
Sp = Array("#", "@", "&", "\", ";", "+", "-", "_", "|")
ch = "%" & Ch1 & "%" & Ch2 & "%"
For i = 0 To UBound(Sp)
ch = Replace(ch, Sp(i), "%")
Next
Do While InStr(1, ch, "%%") > 0
ch = Replace(ch, "%%", "%")
Loop
JoinStr = ch
End If
End Function
'==============================================================
Function SetVl(ByVal ch As String, Thua As Boolean) As String
Dim mStr, mCh, tm, i, j
If ch = "%" Then
Exit Function
Else
If Thua Then
mStr = " th" & ChrW(7917) & "a"
Else
mStr = " t" & ChrW(7901) & " b" & ChrW(7843) & "n " & ChrW(273) & ChrW(7891)
End If
mCh = Mid(ch, 2, Len(ch) - 2)
tm = Split(mCh, "%")
If UBound(tm) = 0 Then
SetVl = tm(0)
Else
SetVl = UBound(tm) + 1 & mStr
End If
End If
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
sealand đã viết:
Để dáp ứng yêu cầu của bạn tôi xin điều chỉnh toàn bộ Code như sau:
Nhấp chuột vào đây để mở rộng...
Em cảm ơn anh sealand!
Code de của anh sealand khi lọc kết quả sang Sheets"TONGHOP" đều cho kết quả như thế này ạ
Ví dụ lọc thôn [TABLE="width: 487"]
[TR]
[TD]Thôn:[/TD]
[TD]Thôn Khuổi Phầy[/TD]
[TD][/TD]
[TD]Mã:[/TD]
[TD]1[/TD]
[/TR]
[/TABLE]
Kết quả cho ra
[TABLE="class: grid, width: 915, align: center"]
[TR]
[TD="align: center"]Thua_dat[/TD]
[TD="align: center"]To_BD[/TD]
[TD="align: center"]Dien_Tich[/TD]
[TD="align: center"]To_BDcu[/TD]
[TD="align: center"]THUA_DATcu[/TD]
[TD="align: center"]DIEN_TICHcu[/TD]
[TD="align: center"]SO_GCNcu[/TD]
[TD="align: center"]NGAY_CAPcu[/TD]
[TD="align: center"]MDSDcu[/TD]
[/TR]
[TR]
[TD="align: center"]13[/TD]
[TD="align: center"]14[/TD]
[TD="align: center"]15[/TD]
[TD="align: center"]28[/TD]
[TD="align: center"]29[/TD]
[TD="align: center"]30[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]10 thửa[/TD]
[TD="align: center"]4 tờ bản đồ[/TD]
[TD="align: center"]3.985,0[/TD]
[TD="align: center"]3 tờ bản đồ[/TD]
[TD="align: center"]10 thửa[/TD]
[TD="align: center"]3.687,00[/TD]
[TD="align: center"]50[/TD]
[TD="align: center"][/TD]
[TD="align: center"] LUC[/TD]
[/TR]
[TR]
[TD="align: center"]11 thửa[/TD]
[TD="align: center"]5 tờ bản đồ[/TD]
[TD="align: center"]4.234,8[/TD]
[TD="align: center"]3 tờ bản đồ[/TD]
[TD="align: center"]12 thửa[/TD]
[TD="align: center"]4.000,00[/TD]
[TD="align: center"]50[/TD]
[TD="align: center"][/TD]
[TD="align: center"] LUC[/TD]
[/TR]
[TR]
[TD="align: center"]6 thửa[/TD]
[TD="align: center"]2 tờ bản đồ[/TD]
[TD="align: center"]1.430,4[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]7 thửa[/TD]
[TD="align: center"]1.738,00[/TD]
[TD="align: center"]50[/TD]
[TD="align: center"][/TD]
[TD="align: center"] LUC[/TD]
[/TR]
[TR]
[TD="align: center"]12 thửa[/TD]
[TD="align: center"]3 tờ bản đồ[/TD]
[TD="align: center"]4.165,9[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]13 thửa[/TD]
[TD="align: center"]3.876,00[/TD]
[TD="align: center"]50[/TD]
[TD="align: center"][/TD]
[TD="align: center"] LUC[/TD]
[/TR]
[TR]
[TD="align: center"]5 thửa[/TD]
[TD="align: center"]2 tờ bản đồ[/TD]
[TD="align: center"]1.121,3[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]5 thửa[/TD]
[TD="align: center"]726,00[/TD]
[TD="align: center"]50[/TD]
[TD="align: center"][/TD]
[TD="align: center"] LUC[/TD]
[/TR]
[TR]
[TD="align: center"]4 thửa[/TD]
[TD="align: center"]6[/TD]
[TD="align: center"]1.188,6[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]4 thửa[/TD]
[TD="align: center"]1.172,00[/TD]
[TD="align: center"]50[/TD]
[TD="align: center"][/TD]
[TD="align: center"] LUC[/TD]
[/TR]
[TR]
[TD="align: center"]5 thửa[/TD]
[TD="align: center"]5[/TD]
[TD="align: center"]837,9[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]4 thửa[/TD]
[TD="align: center"]1.576,00[/TD]
[TD="align: center"]50[/TD]
[TD="align: center"][/TD]
[TD="align: center"] LUC[/TD]
[/TR]
[TR]
[TD="align: center"]60[/TD]
[TD="align: center"]6[/TD]
[TD="align: center"]872,2[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]682[/TD]
[TD="align: center"]798,00[/TD]
[TD="align: center"]50[/TD]
[TD="align: center"][/TD]
[TD="align: center"] LUC[/TD]
[/TR]
[TR]
[TD="align: center"]5 thửa[/TD]
[TD="align: center"]3 tờ bản đồ[/TD]
[TD="align: center"]1.605,5[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]5 thửa[/TD]
[TD="align: center"]1.168,00[/TD]
[TD="align: center"]50[/TD]
[TD="align: center"][/TD]
[TD="align: center"] LUC[/TD]
[/TR]
[TR]
[TD="align: center"]3 thửa[/TD]
[TD="align: center"]2 tờ bản đồ[/TD]
[TD="align: center"]1.038,1[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]3 thửa[/TD]
[TD="align: center"]1.004,00[/TD]
[TD="align: center"]50[/TD]
[TD="align: center"][/TD]
[TD="align: center"] LUC[/TD]
[/TR]
[TR]
[TD="align: center"]3 thửa[/TD]
[TD="align: center"]2 tờ bản đồ[/TD]
[TD="align: center"]723,9[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]3 thửa[/TD]
[TD="align: center"]674,00[/TD]
[TD="align: center"]50[/TD]
[TD="align: center"][/TD]
[TD="align: center"] LUC[/TD]
[/TR]
[/TABLE]
Kết quả ghi ở To_BDcu chưa đúng ạ vì cột THUA_DATcu ghi là 7 thửa
Đúng là ở cột To_BDcu ghi là 1 tờ bản đồ, cột THUA_DATcu ghi là 7 thưa
Còn các cột SO_GCNcu, NGAY_CAPcu, MDSDcu chi ghi khi cột THUA_DATcu = số 1
Mong được anh kiểm tra lại giúp em ạ
 
Lần chỉnh sửa cuối:
Upvote 0
Đây làm bảng dữ liệu khi lọc sang Sheets"TONGHOP" mà em mong muốn
[TABLE="class: grid, width: 934, align: center"]
[TR]
[TD="align: center"]CQL[/TD]
[TD="align: center"]Diachi_ChuSD[/TD]
[TD="align: center"]Thua_dat[/TD]
[TD="align: center"]To_BD[/TD]
[TD="align: center"]To_BDcu[/TD]
[TD="align: center"]THUA_DATcu[/TD]
[TD="align: center"]SO_GCNcu[/TD]
[TD="align: center"]NGAY_CAPcu[/TD]
[TD="align: center"]MDSDcu[/TD]
[/TR]
[TR]
[TD="align: center"]2[/TD]
[TD="align: center"]3[/TD]
[TD="align: center"]13[/TD]
[TD="align: center"]14[/TD]
[TD="align: center"]28[/TD]
[TD="align: center"]29[/TD]
[TD="align: center"]31[/TD]
[TD="align: center"]01/02/1900[/TD]
[TD="align: center"]33[/TD]
[/TR]
[TR]
[TD="align: center"]Lý Văn Đoàn[/TD]
[TD="align: center"]Thôn Khuổi Phầy[/TD]
[TD="align: center"]10 thửa[/TD]
[TD="align: center"]1 tờ bản đồ[/TD]
[TD="align: center"]3 tờ bản đồ[/TD]
[TD="align: center"]10 thửa[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]Lý Văn Hải[/TD]
[TD="align: center"]Thôn Khuổi Phầy[/TD]
[TD="align: center"]11 thửa[/TD]
[TD="align: center"]5 tờ bản đồ[/TD]
[TD="align: center"]3 tờ bản đồ[/TD]
[TD="align: center"]12 thửa[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]Mã Ngọc Bằng[/TD]
[TD="align: center"]Thôn Khuổi Phầy[/TD]
[TD="align: center"]6 thửa[/TD]
[TD="align: center"]2 tờ bản đồ[/TD]
[TD="align: center"]1 tờ bản đồ[/TD]
[TD="align: center"]7 thửa[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]Mã Văn Chí[/TD]
[TD="align: center"]Thôn Khuổi Phầy[/TD]
[TD="align: center"]12 thửa[/TD]
[TD="align: center"]3 tờ bản đồ[/TD]
[TD="align: center"]1 tờ bản đồ[/TD]
[TD="align: center"]13 thửa[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]Mã Văn Dáy[/TD]
[TD="align: center"]Thôn Khuổi Phầy[/TD]
[TD="align: center"]5 thửa[/TD]
[TD="align: center"]2 tờ bản đồ[/TD]
[TD="align: center"]1 tờ bản đồ[/TD]
[TD="align: center"]5 thửa[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]Mã Văn Nguyên[/TD]
[TD="align: center"]Thôn Khuổi Phầy[/TD]
[TD="align: center"]4 thửa[/TD]
[TD="align: center"]1 tờ bản đồ[/TD]
[TD="align: center"]1 tờ bản đồ[/TD]
[TD="align: center"]5 thửa[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]Mã Văn Thắng[/TD]
[TD="align: center"]Thôn Khuổi Phầy[/TD]
[TD="align: center"]5 thửa[/TD]
[TD="align: center"]1 tờ bản đồ[/TD]
[TD="align: center"]1 tờ bản đồ[/TD]
[TD="align: center"]5 thửa[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]Mã Văn Tiến[/TD]
[TD="align: center"]Thôn Khuổi Phầy[/TD]
[TD="align: center"]60[/TD]
[TD="align: center"]6[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]682[/TD]
[TD="align: center"]57[/TD]
[TD="align: center"][/TD]
[TD="align: center"]LUC[/TD]
[/TR]
[TR]
[TD="align: center"]Mã Văn Tựa[/TD]
[TD="align: center"]Thôn Khuổi Phầy[/TD]
[TD="align: center"]5 thửa[/TD]
[TD="align: center"]3 tờ bản đồ[/TD]
[TD="align: center"]1 tờ bản đồ[/TD]
[TD="align: center"]5 thửa[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]Vi Văn Đội[/TD]
[TD="align: center"]Thôn Khuổi Phầy[/TD]
[TD="align: center"]3 thửa[/TD]
[TD="align: center"]2 tờ bản đồ[/TD]
[TD="align: center"]1 tờ bản đồ[/TD]
[TD="align: center"]3 thửa[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]Vy Văn Bộ[/TD]
[TD="align: center"]Thôn Khuổi Phầy[/TD]
[TD="align: center"]3 thửa[/TD]
[TD="align: center"]2 tờ bản đồ[/TD]
[TD="align: center"]1 tờ bản đồ[/TD]
[TD="align: center"]3 thửa[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[/TABLE]

Mong được sự giúp đỡ từ các anh và các thành viên trên diễn đàn!
 
Lần chỉnh sửa cuối:
Upvote 0
Mình xoá file đính kèm bài trước, ban kiểm tra file này xem sao:

Mã: 
Sub GPExyz()
Dim Dic As Object, sArr(), dArr(), Col(), i As Long, j As Long, k As Long, GPE, Id
Dim DKThon As String, DKMa As Long
Set Dic = CreateObject("Scripting.Dictionary")
DKThon = UCase(Sheets("TONGHOP").[B2])
DKMa = Sheets("TONGHOP").[E2].Value
    sArr = Sheets("Data").Range(Sheets("Data").[A3], Sheets("Data").[A3].End(xlDown)).Resize(, 44).Value
For i = 1 To UBound(sArr, 1)
    'Kiem tra neu dung Thon va CMND thi thuc hien 2 viec sau
    If UCase(sArr(i, 3)) = DKThon And sArr(i, 44) = DKMa Then
            'Neu trong Danh sach chua co thi Bo xung vao Danh sach
            If Not Dic.Exists(sArr(i, 5)) Then
            k = k + 1
            Dic.Add sArr(i, 5), k
            ReDim Preserve dArr(1 To 22, 1 To k)
            For j = 1 To 11
            dArr(j, k) = sArr(i, j + 1)
            Next
            dArr(21, k) = sArr(i, 26)
            dArr(22, k) = sArr(i, 27)
            End If
            'Tong hop du lieu vao Danh sach
            Id = Dic.Item(sArr(i, 5))
            dArr(12, Id) = JoinStr(dArr(12, Id), sArr(i, 13))
            dArr(13, Id) = JoinStr(dArr(13, Id), sArr(i, 14))
            dArr(14, Id) = dArr(14, Id) + sArr(i, 15)
            dArr(15, Id) = JoinStr(dArr(15, Id), sArr(i, 28))
            dArr(16, Id) = JoinStr(dArr(16, Id), sArr(i, 29))
            dArr(17, Id) = dArr(17, Id) + sArr(i, 30)
            If sArr(i, 31) <> "" Then dArr(18, Id) = JoinStr(dArr(18, Id), sArr(i, 31))
            If sArr(i, 32) <> "" Then dArr(19, Id) = JoinStr(dArr(19, Id), sArr(i, 32))
            If sArr(i, 33) <> "" Then dArr(20, Id) = JoinStr(dArr(20, Id), sArr(i, 33))
    End If
  Next
          For i = 1 To k
                dArr(12, i) = SetVl(dArr(12, i), True)
                dArr(13, i) = SetVl(dArr(13, i), False)
                dArr(16, i) = SetVl(dArr(16, i), True)
                dArr(15, i) = SetVl(dArr(15, i), False, Right(dArr(16, i), 4) = "th" & ChrW(7917) & "a")
                If Right(dArr(16, i), 4) = "th" & ChrW(7917) & "a" Then
                    dArr(18, i) = ""
                    dArr(19, i) = ""
                    dArr(20, i) = ""
                Else
                    dArr(18, i) = Replace(dArr(18, Id), "%", "  ")
                    dArr(19, i) = Replace(dArr(19, Id), "%", "  ")
                    dArr(20, i) = Replace(dArr(20, Id), "%", "  ")
                End If
         Next
With Sheets("TONGHOP")
    .[A5:A1000].Resize(, 22).ClearContents
    If k Then .[A5].Resize(k, 22).Value = WorksheetFunction.Transpose(dArr)
End With
End Sub
'==========================================================
Function JoinStr(ByVal Ch1 As String, ByVal Ch2 As String) As String
Dim Sp(), ch As String, i
Ch1 = Trim(Ch1): Ch2 = Trim(Ch2)
If InStr(1, Ch1, "%" & Ch2 & "%") > 0 Then
JoinStr = Ch1
Exit Function
Else
Sp = Array("#", "@", "&", "\", ";", "+", "-", "_", "|")
ch = "%" & Ch1 & "%" & Ch2 & "%"
For i = 0 To UBound(Sp)
ch = Replace(ch, Sp(i), "%")
Next
Do While InStr(1, ch, "%%") > 0
ch = Replace(ch, "%%", "%")
Loop
JoinStr = ch
End If
End Function
'=====================================================================
Function SetVl(ByVal ch As String, Thua As Boolean, Optional Dk As Boolean = True) As String
Dim mStr, mCh, tm, i, j
If ch = "%" Then
Exit Function
Else
If Thua Then
mStr = " th" & ChrW(7917) & "a"
Else
mStr = " t" & ChrW(7901) & " b" & ChrW(7843) & "n " & ChrW(273) & ChrW(7891)
End If
mCh = Mid(ch, 2, Len(ch) - 2)
tm = Split(mCh, "%")
If UBound(tm) = 0 Then
If Thua Then
SetVl = tm(0)
Else
 SetVl = IIf(Dk, 1 & mStr, tm(0))
End If
Else
SetVl = UBound(tm) + 1 & mStr
End If
End If
End Function
 

File đính kèm

Upvote 0
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

hoangluongvinh
Cách nhặt các dữ liệu bị trùng của 1 đối tượng (1 người xem)
Trả lời
4
Đọc
85
hoangluongvinh
hoangluongvinh
H
xin mọi người giúp em làm tròn với ạ
Trả lời
4
Đọc
64
NguyenHoangDiep
N
T
  • Question Question
Lọc dữ liệu có nhiều điều kiện
Trả lời
1
Đọc
60
hoangtuaotrang_hp_vn
H
N
  • Question Question
Cách viết tiếng việt có dấu trong msgbox,....... Hoàn toàn mới
    • Thích
2
Trả lời
34
Đọc
4K
Hoàng Tuấn 868
H
longhungvnpost
cả nhà giúp e tạo ô tìm kiếm gợi ý trong danh sách nhé
Trả lời
3
Đọc
82
longhungvnpost
longhungvnpost
S
Cố định độ rộng/ cao của cột/hàng?
Trả lời
12
Đọc
17K
khanhnth02
K
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
15 16 17
Trả lời
329
Đọc
26K
tt_kimbai
T
dung1983
Hỏi về import - Table/ XML cho bảng, trang có chứa JS (1 người xem)
Trả lời
0
Đọc
48
dung1983
dung1983
HeSanbi
  • Đã giải quyết
VBA_FastCode v2.22 - Công cụ học và viết mã VBA một cách nhanh nhất (*27/10/2023) (18 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
2 3
Trả lời
51
Đọc
15K
HeSanbi
HeSanbi
Manhhung90
Mail merge in ấn theo từng trang mong muốn.
Trả lời
1
Đọc
98
Hoàng Tuấn 868
H
L
Xin giúp đỡ đổi màu chữ trong mathtype powerpoint sang màu đen (1 người xem)
Trả lời
4
Đọc
126
LINHCM
L
ongke0711
  • Question Question
Form Đăng nhập và phân quyền cơ bản (1 người xem)
    • Thích
2 3
Trả lời
40
Đọc
5K
Gà Công Nghệ
Gà Công Nghệ
vnxgiokinhtoi
Nhờ giúp đỡ công thức lưu dữ liệu và mở lại dữ liệu cũ đã save
Trả lời
6
Đọc
211
DeTong
D
A
  • Question Question
Addin lúc hiện lúc không
Trả lời
1
Đọc
96
anhdepjai
A
T
  • Question Question
Ẩn hiện các sheet khi click vào HyperLink
Trả lời
6
Đọc
295
Gà Công Nghệ
Gà Công Nghệ
20050911
File Excel lỗi ''The file could not be accessed. Try one of the following:.."
Trả lời
17
Đọc
3K
chienthang2682
C
C
Tải kết quả xổ số 3 miền về excel
    • Thích
3 4 5
Trả lời
98
Đọc
13K
HNam_Phan
H
S
Xuất các bảng công phụ từ bảng công chính trong gg sheet
Trả lời
0
Đọc
99
sirhungvla
S
T
Nhờ ACE chỉ giáo công thức Gộp nhiều dữ liệu vào một ô trong excel
Trả lời
11
Đọc
365
Hoàng Tuấn 868
H
PhanTuHuong
Nên chọn điện thoại nào?
2
Trả lời
21
Đọc
1K
minhminh27
minhminh27
Xem thêm…

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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom