mình cần trích lọc 1 danh sách có 1 số hoten và namsinh trùng nhau và copy cả 2 hoặc 3 người trùng đó qua Sheet mới, hôm trước được bạn hoangminhtien trợ giúp nhưng còn thiếu 1 chút! Lọc theo 2 tiêu chí "hoten" và 'namsinh"; nếu cả 2 giống nhau thì copy cả 2 qua Sheet mới Mình gửi file đính kèm để anh chị hiểu rõ ý mình nói!
mình cần trích lọc 1 danh sách có 1 số hoten và namsinh trùng nhau và copy cả 2 hoặc 3 người trùng đó qua Sheet mới, hôm trước được bạn hoangminhtien trợ giúp nhưng còn thiếu 1 chút! Lọc theo 2 tiêu chí "hoten" và 'namsinh"; nếu cả 2 giống nhau thì copy cả 2 qua Sheet mới Mình gửi file đính kèm để anh chị hiểu rõ ý mình nói!
Đã có người làm rồi sao không hỏi tiếp ở topic kia mà mở topic mới?
Tặng bạn code này chạy thử xem sao:
PHP:
Public Sub GPE()
Dim Dic As Object, I As Long, Tem As String, K As Long, J As Long, sArr(), dArr()
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DS Goc")
sArr = .Range(.[A2], .[A65000].End(xlUp)).Resize(, 8).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 8)
For I = 1 To UBound(sArr, 1)
Tem = UCase(sArr(I, 2)) & "#" & sArr(I, 3)
If Not Dic.Exists(Tem) Then
Dic.Add Tem, 1
Else
Dic.Item(Tem) = 2
End If
Next I
For I = 1 To UBound(sArr, 1)
Tem = UCase(sArr(I, 2)) & "#" & sArr(I, 3)
If Dic.Item(Tem) = 2 Then
K = K + 1
For J = 1 To 8
dArr(K, J) = sArr(I, J)
Next J
End If
Next I
With Sheets("DS LOC")
.[A2:H65000].ClearContents
.[A2].Resize(K, 8).Value = dArr
.[A2].Resize(K, 8).Borders.LineStyle = xlContinuous
End With
Set Dic = Nothing
End Sub
Rất cảm ơn bạn Beta giải đáp, rất pro nhưng mình thì chẳng hiểu tí tẹo nào hết.hix
Nếu mình nhập thêm người vào Ds Goc thì nó có tự động trích lọc thêm những người trùng đưa qua sheet trích lọc nữa không?
Có dùng trích lọc mà ko cần Code Macro được không, nếu không được thì hướng dẫn mình chạy code mỗi khi cập nhật danh sách góc! thêm cái nữa là thêm điều kiện là trùng luôn "diachi" tức lọc trùng 3 tiêu chí thì mới lấy. mong bạn thông cảm, thật sự mình cần lắm những yêu cầu như thế!
Rất cảm ơn bạn Beta giải đáp, rất pro nhưng mình thì chẳng hiểu tí tẹo nào hết.hix
Nếu mình nhập thêm người vào Ds Goc thì nó có tự động trích lọc thêm những người trùng đưa qua sheet trích lọc nữa không?
Có dùng trích lọc mà ko cần Code Macro được không, nếu không được thì hướng dẫn mình chạy code mỗi khi cập nhật danh sách góc! thêm cái nữa là thêm điều kiện là trùng luôn "diachi" tức lọc trùng 3 tiêu chí thì mới lấy. mong bạn thông cảm, thật sự mình cần lắm những yêu cầu như thế!
Trong tay bạn đã có Code của Batê, bạn chỉ cần nhập dữ liệu vào Sheet DS Goc thỏa mãn tiêu chí cùng hoten và namsinh thì sẽ có kết quả mong muốn ở DS Loc. Vậy thôi.
Rất cảm ơn bạn Beta giải đáp, rất pro nhưng mình thì chẳng hiểu tí tẹo nào hết.hix
Nếu mình nhập thêm người vào Ds Goc thì nó có tự động trích lọc thêm những người trùng đưa qua sheet trích lọc nữa không?
Có dùng trích lọc mà ko cần Code Macro được không, nếu không được thì hướng dẫn mình chạy code mỗi khi cập nhật danh sách góc! thêm cái nữa là thêm điều kiện là trùng luôn "diachi" tức lọc trùng 3 tiêu chí thì mới lấy. mong bạn thông cảm, thật sự mình cần lắm những yêu cầu như thế!
Dùng Advanced Filter cho nó khỏe! Làm bằng tay cũng được, mà viết thành code cũng ngắn gọn vầy thôi:
Mã:
Private Sub Worksheet_Activate()
Dim wks As Worksheet
Set wks = Worksheets("DS Goc")
Range("A1:H1000").Clear
wks.Range("IV2").Value = "=SUMPRODUCT(($B$2:$B$1000=$B2)*($C$2:$C$1000=$C2)*($E$2:$E$1000=$E2))>1"
wks.Range("A1:H1000").AdvancedFilter 2, wks.Range("IV1:IV2"), Range("A1")
wks.Range("IV1:IV2").Clear
End Sub
Xong!
Bạn làm gì bên sheet DS Goc cứ thây kệ, hể sang bên sheet LOC là dữ liệu sẽ tự cập nhất
(Bấm Alt + F11 để xem code)
, và những bạn đã giúp đỡ mình! và cho mình hỏi danh sách góc của mình chỉ là mẫu thôi, mai mốt mình đưa thêm vào danh sách góc 1 số lượng rất lớn lên tới "vài chục ngìn người", việc trích lọc vẫn không ảnh hường gì chứ?
, và những bạn đã giúp đỡ mình! và cho mình hỏi danh sách góc của mình chỉ là mẫu thôi, mai mốt mình đưa thêm vào danh sách góc 1 số lượng rất lớn lên tới "vài chục ngìn người", việc trích lọc vẫn không ảnh hường gì chứ?
File này mình từ topic về chủ đề là tách tỉnh, mình sửa lại 1 chút,nhưng có chỗ mình không bít sửa sao.
Bạn làm ơn giúp mình thêm chút nhé, cảm ơn bạn nhiều lắm!
Cái công thức LOOKUP(2,1/COUNTIF($A2,"*"&DMT&"*"),DMT)
Chỗ "*"&DMT&"*" DMT làm sao sửa được, lúc trước nó là danh mục tỉnh, bạn làm ơn chỉ mình cách sửa phù hợp với tên file giúp mình!
Chẳng hạn: LOOKUP(2,1/COUNTIF($A2,"*"&tenxa&"*"),tenxa) có được ko?
File này mình từ topic về chủ đề là tách tỉnh, mình sửa lại 1 chút,nhưng có chỗ mình không bít sửa sao.
Bạn làm ơn giúp mình thêm chút nhé, cảm ơn bạn nhiều lắm!
Cái công thức LOOKUP(2,1/COUNTIF($A2,"*"&DMT&"*"),DMT)
Chỗ "*"&DMT&"*" DMT làm sao sửa được, lúc trước nó là danh mục tỉnh, bạn làm ơn chỉ mình cách sửa phù hợp với tên file giúp mình!
Chẳng hạn: LOOKUP(2,1/COUNTIF($A2,"*"&tenxa&"*"),tenxa) có được ko?
Với dữ liệu vài chục ngàn dòng thì không nên dùng Advanced Filter (tôi test tốc độ rất chậm)
Vậy bạn có 2 lựa chọn:
- Sửa lại code của anh Ba Tê (thêm 1 điều kiện nữa)
- Dùng code của tôi:
Mã:
Sub Main()
Dim wksSrc As Worksheet, wksDes As Worksheet, Dic As Object
Dim aSrc, arr, aPos()
Dim aTmp(1 To 3) As String, tmp As String
Dim lR As Long, lC As Long, n As Long, lEndCol As Long, lEndRow As Long
On Error Resume Next
Set wksSrc = Worksheets("DS Goc")
Set wksDes = Worksheets("DS LOC")
wksDes.Range("[COLOR=#006400]A2:H60000[/COLOR]").Clear
Set Dic = CreateObject("Scripting.Dictionary")
[COLOR=#ff0000]Dic.CompareMode = vbTextCompare[/COLOR]
aSrc = wksSrc.Range("[COLOR=#006400]A2:H60000[/COLOR]")
lEndRow = UBound(aSrc, 1): lEndCol = UBound(aSrc, 2)
ReDim Preserve aSrc(1 To lEndRow, 1 To lEndCol + 1)
For lR = 1 To lEndRow
aTmp(1) = aSrc(lR, 2): aTmp(2) = aSrc(lR, 3): aTmp(3) = aSrc(lR, 5)
tmp = Join(aTmp, "")
If Len(tmp) Then
tmp = Join(aTmp, vbBack)
If Not Dic.Exists(tmp) Then
Dic.Add tmp, lR
Else
n = n + 1
aSrc(lR, lEndCol + 1) = 1
If Dic.Item(tmp) > 0 Then
aSrc(Dic.Item(tmp), lEndCol + 1) = 1
Dic.Item(tmp) = 0
n = n + 1
End If
End If
End If
Next
If n Then
ReDim arr(1 To n, 1 To lEndCol)
n = 0
For lR = 1 To lEndRow
If aSrc(lR, lEndCol + 1) = 1 Then
n = n + 1
For lC = 1 To lEndCol
arr(n, lC) = aSrc(lR, lC)
Next
End If
Next
With wksDes.Range("A2").Resize(n, lEndCol)
.Value = arr
.Borders.LineStyle = 1
End With
End If
End Sub
và code sửa kiện:
Mã:
[COLOR=#0000cd]Private Sub Worksheet_Activate()
Main
End Sub[/COLOR]
Lưu ý:
- Chổ màu xanh lá là giới hạn dữ liệu. Hiện tôi đang thiết kế đến 60000 dòng, nếu nhiều hơn, bạn sửa lại chổ này nhé
- Code màu xanh là code sự kiện tại sheet DS LOC, nó sẽ tự động lọc khi bạn chuyển vào sheet DS LOC
- Nếu không thích tự động, có thể tạo 1 nút bấm, khi bấm vào thì code sẽ chạy (khi ấy ta xóa code màu xanh đi)
- Dòng màu đỏ phía trên vô cùng quan trọng: Có nó thì code sẽ không phân biệt HOA thường trong dữ liệu nhập và ngược lại
- Tôi chuyển luôn định dạng file thành xlsm luôn (dùng trên Excel 2007 hoặc 2010)
Với dữ liệu vài chục ngàn dòng thì không nên dùng Advanced Filter (tôi test tốc độ rất chậm)
Vậy bạn có 2 lựa chọn:
- Sửa lại code của anh Ba Tê (thêm 1 điều kiện nữa)
- Dùng code của tôi:
Mã:
Sub Main()
Dim wksSrc As Worksheet, wksDes As Worksheet, Dic As Object
Dim aSrc, arr, aPos()
Dim aTmp(1 To 3) As String, tmp As String
Dim lR As Long, lC As Long, n As Long, lEndCol As Long, lEndRow As Long
On Error Resume Next
Set wksSrc = Worksheets("DS Goc")
Set wksDes = Worksheets("DS LOC")
wksDes.Range("[COLOR=#006400]A2:H60000[/COLOR]").Clear
Set Dic = CreateObject("Scripting.Dictionary")
[COLOR=#ff0000]Dic.CompareMode = vbTextCompare[/COLOR]
aSrc = wksSrc.Range("[COLOR=#006400]A2:H60000[/COLOR]")
lEndRow = UBound(aSrc, 1): lEndCol = UBound(aSrc, 2)
ReDim Preserve aSrc(1 To lEndRow, 1 To lEndCol + 1)
For lR = 1 To lEndRow
aTmp(1) = aSrc(lR, 2): aTmp(2) = aSrc(lR, 3): aTmp(3) = aSrc(lR, 5)
tmp = Join(aTmp, "")
If Len(tmp) Then
tmp = Join(aTmp, vbBack)
If Not Dic.Exists(tmp) Then
Dic.Add tmp, lR
Else
n = n + 1
aSrc(lR, lEndCol + 1) = 1
If Dic.Item(tmp) > 0 Then
aSrc(Dic.Item(tmp), lEndCol + 1) = 1
Dic.Item(tmp) = 0
n = n + 1
End If
End If
End If
Next
If n Then
ReDim arr(1 To n, 1 To lEndCol)
n = 0
For lR = 1 To lEndRow
If aSrc(lR, lEndCol + 1) = 1 Then
n = n + 1
For lC = 1 To lEndCol
arr(n, lC) = aSrc(lR, lC)
Next
End If
Next
With wksDes.Range("A2").Resize(n, lEndCol)
.Value = arr
.Borders.LineStyle = 1
End With
End If
End Sub
và code sửa kiện:
Mã:
[COLOR=#0000cd]Private Sub Worksheet_Activate()
Main
End Sub[/COLOR]
Lưu ý:
- Chổ màu xanh lá là giới hạn dữ liệu. Hiện tôi đang thiết kế đến 60000 dòng, nếu nhiều hơn, bạn sửa lại chổ này nhé
- Code màu xanh là code sự kiện tại sheet DS LOC, nó sẽ tự động lọc khi bạn chuyển vào sheet DS LOC
- Nếu không thích tự động, có thể tạo 1 nút bấm, khi bấm vào thì code sẽ chạy (khi ấy ta xóa code màu xanh đi)
- Dòng màu đỏ phía trên vô cùng quan trọng: Có nó thì code sẽ không phân biệt HOA thường trong dữ liệu nhập và ngược lại
- Tôi chuyển luôn định dạng file thành xlsm luôn (dùng trên Excel 2007 hoặc 2010)
