Giúp Code lọc dữ liệu theo điều kiện

[baquang1984]

Em chào Thầy cô và anh chị trên diễn đàn giúp đỡ ạ
Em có biểu như file đính kèm muốn lọc dữ liệu từ 2 Sheet là Sheets"So_DC" và Sheets"Solieu_KK" sang Sheets"DS_Loc" theo điều kiện là khi chọn điều kiện lọc trong List ở Cell O3 thì dữ liệu ở 2 Sheet là Sheets"So_DC" và Sheets"Solieu_KK" được lọc sang Sheets"DS_Loc" và dữ liệu được lấy vào các cột tương ứng như sau ở bảng "Theo sổ địa chính" Dữ liệu lấy ở Sheets"So_DC" các cột:
CQL lấy dữ liệu từ cột Tên chủ sử dụng
Số phát hành lấy dữ liệu từ cột Số quản lý
Số vào sổ lấy dữ liệu từ cột Vào sổ cấp GCN
Căn cứ pháp lý vào sổ lấy dữ liệu từ cột Căn cứ pháp lý vào sổ
Thua_dat lấy dữ liệu từ cột Thửa số
To_BD lấy dữ liệu từ cột Tờ bản đồ số
Dien_Tich lấy dữ liệu từ cột Diện tích
MDSD lấy dữ liệu từ cột Mục đích sử dụng
Xu_Dong lấy dữ liệu từ cột Địa danh thửa đất
Thoihan_SD lấy dữ liệu từ cột Thời hạn sử dụng
ở bảng "Theo kết quả kê khai" Dữ liệu lấy ở Sheets"Solieu_KK" các cột:
CQL lấy dữ liệu từ cột CQL1
Năm sinh lấy dữ liệu từ cột Năm sinh
Thua_Dat lấy dữ liệu từ cột Shthua_Cu
To_BD lấy dữ liệu từ cộtTo_BD_Cu
Diện_Tích lấy dữ liệu từ cột DienTich_Cu
MDSD lấy dữ liệu từ cột MDSD_Cu
Mong được sự giúp đỡ của Thầy cô và các anh chị trên diễn đạn ạ
Em cảm ơn nhiêu

 

[be_09]

Đâu có quy định nào phải tra như sheet DS_Loc, vậy mục đích làm như vậy để làm gì?

 

[baquang1984]

Đâu có quy định nào phải tra như sheet DS_Loc, vậy mục đích làm như vậy để làm gì?

Cảm ơn anh. Em làm biểu này để làm công việc khác không phải là tra anh ạ và cũng không có quy định gì cả. chỉ là không biết làm thế nào nên up lên nhơ diễn đàn giúp đỡ thôi ạ.

 

[be_09]

Cảm ơn anh. Em làm biểu này để làm công việc khác không phải là tra anh ạ và cũng không có quy định gì cả. chỉ là không biết làm thế nào nên up lên nhơ diễn đàn giúp đỡ thôi ạ.

Vậy thì cần giải thích rỏ hơn nữa là mỗi lần tra để biết thông tin của 1 chủ sử dụng hay nhiều chủ sử dụng rồi nối tiếp theo xuống dưới, để các thành viên hiểu mới giúp được.

 

[baquang1984]

Vậy thì cần giải thích rỏ hơn nữa là mỗi lần tra để biết thông tin của 1 chủ sử dụng hay nhiều chủ sử dụng rồi nối tiếp theo xuống dưới, để các thành viên hiểu mới giúp được.

Vâng như em giải thích ở trên là chỉ cần chọn điều kiện lọc ở Cell O3 và kiểm tra kiểm tra thỏa mãn với các dữ liệu ở 2 sheet là Sheets"So_DC" và Sheets"Solieu_KK" và lọc sang thôi ạ vì ở 2 sheet này đều có chung dữ liệu trong list ở Cell O3
Em cảm ơn anh

 

[HieuCD]

dùng sự kiện

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$O$3" Then
  Application.ScreenUpdating = False
  Dim DCarr(), KKarr(), Arr(), KK, DC, i As Long, j As Long, k As Long, Gan As Boolean
  DC = Array("", 5, 4, 7, 8, 6, 9)
  KK = Array("", 7, 8, 10, 9)
  If Range("K" & Rows.Count).End(xlUp).Row > 4 Then
    Range("A2", Range("K" & Rows.Count).End(xlUp)).ClearContents
  End If
  With Sheets("So_DC")
    .Range("A2").AutoFilter
    DCarr = .Range("A2", .Range("L" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("Solieu_KK")
    .Range("A2").AutoFilter
    KKarr = .Range("A2", .Range("T" & Rows.Count).End(xlUp)).Value
  End With

  ReDim Arr(1 To UBound(DCarr), 1 To 6)
  For i = 1 To UBound(DCarr)
    If DCarr(i, 12) = Target.Value Then
      k = k + 1
      For j = 1 To UBound(DC)
        Arr(k, j) = DCarr(i, DC(j))
      Next j
      If Gan = False Then
        Range("B2") = DCarr(k, 1):      Range("D2") = Target
        Range("F2") = DCarr(k, 11):     Range("C3") = DCarr(k, 10)
        Gan = True
      End If
    End If
  Next i
  If k Then Range("A5").Resize(k, 6) = Arr

  Gan = False:  k = 0
  ReDim Arr(1 To UBound(KKarr), 1 To 4)
  For i = 1 To UBound(KKarr)
    If KKarr(i, 15) = Target.Value Then
      k = k + 1
      For j = 1 To UBound(KK)
        Arr(k, j) = KKarr(i, KK(j))
      Next j
      If Gan = False Then
        Range("I2") = KKarr(k, 1):  Range("K2") = KKarr(k, 20)
        Gan = True
      End If
    End If
  Next i
  If k Then Range("H5").Resize(k, 4) = Arr
  Application.ScreenUpdating = True
End If
End Sub

 

[baquang1984]

dùng sự kiện

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$O$3" Then
  Application.ScreenUpdating = False
  Dim DCarr(), KKarr(), Arr(), KK, DC, i As Long, j As Long, k As Long, Gan As Boolean
  DC = Array("", 5, 4, 7, 8, 6, 9)
  KK = Array("", 7, 8, 10, 9)
  If Range("K" & Rows.Count).End(xlUp).Row > 4 Then
    Range("A2", Range("K" & Rows.Count).End(xlUp)).ClearContents
  End If
  With Sheets("So_DC")
    .Range("A2").AutoFilter
    DCarr = .Range("A2", .Range("L" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("Solieu_KK")
    .Range("A2").AutoFilter
    KKarr = .Range("A2", .Range("T" & Rows.Count).End(xlUp)).Value
  End With

  ReDim Arr(1 To UBound(DCarr), 1 To 6)
  For i = 1 To UBound(DCarr)
    If DCarr(i, 12) = Target.Value Then
      k = k + 1
      For j = 1 To UBound(DC)
        Arr(k, j) = DCarr(i, DC(j))
      Next j
      If Gan = False Then
        Range("B2") = DCarr(k, 1):      Range("D2") = Target
        Range("F2") = DCarr(k, 11):     Range("C3") = DCarr(k, 10)
        Gan = True
      End If
    End If
  Next i
  If k Then Range("A5").Resize(k, 6) = Arr

  Gan = False:  k = 0
  ReDim Arr(1 To UBound(KKarr), 1 To 4)
  For i = 1 To UBound(KKarr)
    If KKarr(i, 15) = Target.Value Then
      k = k + 1
      For j = 1 To UBound(KK)
        Arr(k, j) = KKarr(i, KK(j))
      Next j
      If Gan = False Then
        Range("I2") = KKarr(k, 1):  Range("K2") = KKarr(k, 20)
        Gan = True
      End If
    End If
  Next i
  If k Then Range("H5").Resize(k, 4) = Arr
  Application.ScreenUpdating = True
End If
End Sub

Cảm ơn anh về chương trình tuy nhiên khi em chạy thì chương trình xóa mất tiêu đề từ dòng A2 ạ và các ô cell ở hàng thứ 2 và 3 không thấy điền dữ liệu vào anh có thể kiểm tra lại giúp em được không ạ
Em cảm ơn nhiều ạ

 

[HieuCD]

Cảm ơn anh về chương trình tuy nhiên khi em chạy thì chương trình xóa mất tiêu đề từ dòng A2 ạ và các ô cell ở hàng thứ 2 và 3 không thấy điền dữ liệu vào anh có thể kiểm tra lại giúp em được không ạ
Em cảm ơn nhiều ạ

bạn chỉnh lại code và kiểm tra lại. "A2" sửa số 2 thành số 5 "A5"

  If Range("K" & Rows.Count).End(xlUp).Row > 4 Then
    Range("A5", Range("K" & Rows.Count).End(xlUp)).ClearContents
  End If

 

[baquang1984]

bạn chỉnh lại code và kiểm tra lại. "A2" sửa số 2 thành số 5 "A5"

  If Range("K" & Rows.Count).End(xlUp).Row > 4 Then
    Range("A5", Range("K" & Rows.Count).End(xlUp)).ClearContents
  End If

Nhưng mà các ô ở dòng 2 và 3 ở bảng "Theo sổ địa chính" đang không chạy ạ và ở bảng "Theo kết quả kê khai" dữ liệu lấy không đúng côt
ở bảng "Theo kết quả kê khai" Dữ liệu lấy ở Sheets"Solieu_KK" các cột:
CQL lấy dữ liệu từ cột CQL1
Năm sinh lấy dữ liệu từ cột Năm sinh
Thua_Dat lấy dữ liệu từ cột Shthua_Cu
To_BD lấy dữ liệu từ cộtTo_BD_Cu
Diện_Tích lấy dữ liệu từ cột DienTich_Cu
MDSD lấy dữ liệu từ cột MDSD_Cu
Mong anh kiểm tra lại giúp ạ
Cảm ơn anh nhiều!

 

[HieuCD]

Nhưng mà các ô ở dòng 2 và 3 ở bảng "Theo sổ địa chính" đang không chạy ạ và ở bảng "Theo kết quả kê khai" dữ liệu lấy không đúng côt
ở bảng "Theo kết quả kê khai" Dữ liệu lấy ở Sheets"Solieu_KK" các cột:
CQL lấy dữ liệu từ cột CQL1
Năm sinh lấy dữ liệu từ cột Năm sinh
Thua_Dat lấy dữ liệu từ cột Shthua_Cu
To_BD lấy dữ liệu từ cộtTo_BD_Cu
Diện_Tích lấy dữ liệu từ cột DienTich_Cu
MDSD lấy dữ liệu từ cột MDSD_Cu
Mong anh kiểm tra lại giúp ạ
Cảm ơn anh nhiều!

bạn chỉnh lại thứ tự cột trong mảng kk

  DC = Array("", 5, 4, 7, 8, 6, 9)
  KK = Array("", 11, 12, 14, 13)
  If Range("F" & Rows.Count).End(xlUp).Row > 4 Then
    Range("A5", Range("F" & Rows.Count).End(xlUp)).ClearContents
  End If
  With Sheets("So_DC")
    .Range("A2").AutoFilter
    DCarr = .Range("A2", .Range("L" & Rows.Count).End(xlUp)).Value
  End With

trong code mình có lấy dữ liệu từ dòng 2 của sheet So_DC

 

[baquang1984]

bạn chỉnh lại thứ tự cột trong mảng kk

  DC = Array("", 5, 4, 7, 8, 6, 9)
  KK = Array("", 11, 12, 14, 13)
  If Range("F" & Rows.Count).End(xlUp).Row > 4 Then
    Range("A5", Range("F" & Rows.Count).End(xlUp)).ClearContents
  End If
  With Sheets("So_DC")
    .Range("A2").AutoFilter
    DCarr = .Range("A2", .Range("L" & Rows.Count).End(xlUp)).Value
  End With

trong code mình có lấy dữ liệu từ dòng 2 của sheet So_DC

Cảm ơn anh tuy nhiên là còn những ô Cel
ở bảng "Theo sổ địa chính"
CQL lấy dữ liệu từ cột Tên chủ sử dụng
Số vào sổ lấy dữ liệu từ cột Vào sổ cấp GCN
Căn cứ pháp lý vào sổ lấy dữ liệu từ cột Căn cứ pháp lý vào sổ
ở bảng "Theo kết quả kê khai" Dữ liệu lấy ở Sheets"Solieu_KK" các cột:
CQL lấy dữ liệu từ cột CQL1
Năm sinh lấy dữ liệu từ cột Năm sinh
Chưa lấy được dữ liệu vào ạ
Mong anh cố gắng giúp đỡ ạ em cảm ơn nhiều

 

[HieuCD]

Cảm ơn anh tuy nhiên là còn những ô Cel
ở bảng "Theo sổ địa chính"
CQL lấy dữ liệu từ cột Tên chủ sử dụng
Số vào sổ lấy dữ liệu từ cột Vào sổ cấp GCN
Căn cứ pháp lý vào sổ lấy dữ liệu từ cột Căn cứ pháp lý vào sổ
ở bảng "Theo kết quả kê khai" Dữ liệu lấy ở Sheets"Solieu_KK" các cột:
CQL lấy dữ liệu từ cột CQL1
Năm sinh lấy dữ liệu từ cột Năm sinh
Chưa lấy được dữ liệu vào ạ
Mong anh cố gắng giúp đỡ ạ em cảm ơn nhiều

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$O$3" Then
  Application.ScreenUpdating = False
  Dim DCarr(), KKarr(), Arr(), KK, DC, i As Long, j As Long, k As Long, Gan As Boolean
  DC = Array("", 5, 4, 7, 8, 6, 9)
  KK = Array("", 11, 12, 14, 13)
  If Range("F" & Rows.Count).End(xlUp).Row > 4 Then
    Range("A5:K" & Range("F" & Rows.Count).End(xlUp).Row).ClearContents
  End If
  With Sheets("So_DC")
    .Range("A2").AutoFilter
    DCarr = .Range("A2", .Range("L" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("Solieu_KK")
    .Range("A2").AutoFilter
    KKarr = .Range("A2", .Range("T" & Rows.Count).End(xlUp)).Value
  End With

  ReDim Arr(1 To UBound(DCarr), 1 To 6)
  For i = 1 To UBound(DCarr)
    If DCarr(i, 12) = Target.Value Then
      k = k + 1
      For j = 1 To UBound(DC)
        Arr(k, j) = DCarr(i, DC(j))
      Next j
      If Gan = False Then
        Range("B2") = DCarr(k, 1):      Range("D2") = Target
        Range("F2") = DCarr(k, 11):     Range("C3") = DCarr(k, 10)
        Gan = True
      End If
    End If
  Next i
  If k Then Range("A5").Resize(k, 6) = Arr

  Gan = False:  k = 0
  ReDim Arr(1 To UBound(KKarr), 1 To 4)
  For i = 1 To UBound(KKarr)
    If KKarr(i, 15) = Target.Value Then
      k = k + 1
      For j = 1 To UBound(KK)
        Arr(k, j) = KKarr(i, KK(j))
      Next j
      If Gan = False Then
        Range("I2") = KKarr(k, 1):  Range("K2") = KKarr(k, 20)
        Gan = True
      End If
    End If
  Next i
  If k Then Range("H5").Resize(k, 4) = Arr
  Application.ScreenUpdating = True
End If
End Sub

các lệnh sau gán giá trị 6 ô trên đầu bảng

      If Gan = False Then
        Range("B2") = DCarr(k, 1):      Range("D2") = Target
        Range("F2") = DCarr(k, 11):     Range("C3") = DCarr(k, 10)
        Gan = True
      End If
      If Gan = False Then
        Range("I2") = KKarr(k, 1):  Range("K2") = KKarr(k, 20)
        Gan = True
      End If

 

[baquang1984]

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$O$3" Then
  Application.ScreenUpdating = False
  Dim DCarr(), KKarr(), Arr(), KK, DC, i As Long, j As Long, k As Long, Gan As Boolean
  DC = Array("", 5, 4, 7, 8, 6, 9)
  KK = Array("", 11, 12, 14, 13)
  If Range("F" & Rows.Count).End(xlUp).Row > 4 Then
    Range("A5:K" & Range("F" & Rows.Count).End(xlUp).Row).ClearContents
  End If
  With Sheets("So_DC")
    .Range("A2").AutoFilter
    DCarr = .Range("A2", .Range("L" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("Solieu_KK")
    .Range("A2").AutoFilter
    KKarr = .Range("A2", .Range("T" & Rows.Count).End(xlUp)).Value
  End With

  ReDim Arr(1 To UBound(DCarr), 1 To 6)
  For i = 1 To UBound(DCarr)
    If DCarr(i, 12) = Target.Value Then
      k = k + 1
      For j = 1 To UBound(DC)
        Arr(k, j) = DCarr(i, DC(j))
      Next j
      If Gan = False Then
        Range("B2") = DCarr(k, 1):      Range("D2") = Target
        Range("F2") = DCarr(k, 11):     Range("C3") = DCarr(k, 10)
        Gan = True
      End If
    End If
  Next i
  If k Then Range("A5").Resize(k, 6) = Arr

  Gan = False:  k = 0
  ReDim Arr(1 To UBound(KKarr), 1 To 4)
  For i = 1 To UBound(KKarr)
    If KKarr(i, 15) = Target.Value Then
      k = k + 1
      For j = 1 To UBound(KK)
        Arr(k, j) = KKarr(i, KK(j))
      Next j
      If Gan = False Then
        Range("I2") = KKarr(k, 1):  Range("K2") = KKarr(k, 20)
        Gan = True
      End If
    End If
  Next i
  If k Then Range("H5").Resize(k, 4) = Arr
  Application.ScreenUpdating = True
End If
End Sub

các lệnh sau gán giá trị 6 ô trên đầu bảng

      If Gan = False Then
        Range("B2") = DCarr(k, 1):      Range("D2") = Target
        Range("F2") = DCarr(k, 11):     Range("C3") = DCarr(k, 10)
        Gan = True
      End If
      If Gan = False Then
        Range("I2") = KKarr(k, 1):  Range("K2") = KKarr(k, 20)
        Gan = True
      End If

Sao vẫn không thấy chạy anh nhỉ anh có thể cho Code vào file em gửi kèm được không ạ

 

[baquang1984]

Những ô cell này vẫn không chạy anh ạ
ở bảng "Theo sổ địa chính"
CQL lấy dữ liệu từ cột Tên chủ sử dụng
Số vào sổ lấy dữ liệu từ cột Vào sổ cấp GCN
Căn cứ pháp lý vào sổ lấy dữ liệu từ cột Căn cứ pháp lý vào sổ
ở bảng "Theo kết quả kê khai" Dữ liệu lấy ở Sheets"Solieu_KK" các cột:
CQL lấy dữ liệu từ cột CQL1
Năm sinh lấy dữ liệu từ cột Năm sinh
Chưa lấy được dữ liệu vào ạ
Mong anh cố gắng giúp đỡ ạ em cảm ơn nhiều

 

[HieuCD]

Những ô cell này vẫn không chạy anh ạ
ở bảng "Theo sổ địa chính"
CQL lấy dữ liệu từ cột Tên chủ sử dụng
Số vào sổ lấy dữ liệu từ cột Vào sổ cấp GCN
Căn cứ pháp lý vào sổ lấy dữ liệu từ cột Căn cứ pháp lý vào sổ
ở bảng "Theo kết quả kê khai" Dữ liệu lấy ở Sheets"Solieu_KK" các cột:
CQL lấy dữ liệu từ cột CQL1
Năm sinh lấy dữ liệu từ cột Năm sinh
Chưa lấy được dữ liệu vào ạ
Mong anh cố gắng giúp đỡ ạ em cảm ơn nhiều

mình nhầm biến, bạn chỉnh lại code

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$O$3" Then
  Application.ScreenUpdating = False
  Dim DCarr(), KKarr(), Arr(), KK, DC, i As Long, j As Long, k As Long, Gan As Boolean
  DC = Array("", 5, 4, 7, 8, 6, 9)
  KK = Array("", 11, 12, 14, 13)
  If Range("F" & Rows.Count).End(xlUp).Row > 4 Then
    Range("A5:K" & Range("F" & Rows.Count).End(xlUp).Row).ClearContents
  End If
  With Sheets("So_DC")
    .Range("A2").AutoFilter
    DCarr = .Range("A2", .Range("L" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("Solieu_KK")
    .Range("A2").AutoFilter
    KKarr = .Range("A2", .Range("T" & Rows.Count).End(xlUp)).Value
  End With

  ReDim Arr(1 To UBound(DCarr), 1 To 6)
  For i = 1 To UBound(DCarr)
    If DCarr(i, 12) = Target.Value Then
      k = k + 1
      For j = 1 To UBound(DC)
        Arr(k, j) = DCarr(i, DC(j))
      Next j
      If Gan = False Then
        Range("B2") = DCarr(i, 1):      Range("D2") = Target
        Range("F2") = DCarr(i, 11):     Range("C3") = DCarr(i, 10)
        Gan = True
      End If
    End If
  Next i
  If k Then Range("A5").Resize(k, 6) = Arr

  Gan = False:  k = 0
  ReDim Arr(1 To UBound(KKarr), 1 To 4)
  For i = 1 To UBound(KKarr)
    If KKarr(i, 15) = Target.Value Then
      k = k + 1
      For j = 1 To UBound(KK)
        Arr(k, j) = KKarr(i, KK(j))
      Next j
      If Gan = False Then
        Range("I2") = KKarr(i, 1):  Range("K2") = KKarr(i, 20)
        Gan = True
      End If
    End If
  Next i
  If k Then Range("H5").Resize(k, 4) = Arr
  Application.ScreenUpdating = True
End If
End Sub