Lọc mảng nhiều điều kiện

tungtruong8924 · 19/7/15

hpkhuong đã viết:
Xài 1 cột phụ (cột F tại sheet Tổng hợp nhé! (Công thức thì file đính kèm.)

Còn code thì thử cái này:

[GPECODE=vb]
Sub Loc()
Dim Sh As Worksheet, Arr(), zArr()
Dim Rws As Long, J&, W&, dk1 As Date, dk2 As String
dk1 = Sheets("CHI TIET").[B1].Value
dk2 = Sheets("CHI TIET").[B2].Value
zArr = Array(2, 3, 5)
Set Sh = Sheets("TONG HOP")
With Sh.[A2]
Rws = .CurrentRegion.Rows.Count
Arr() = .Resize(Rws, 5).Value
End With
ReDim dArr(1 To Rws, 1 To 3)
For J = 1 To UBound(Arr())
If Arr(J, 1) = dk1 And Arr(J, 4) = dk2 Then
W = 1 + W
For Z = 0 To UBound(zArr)
dArr(W, Z + 1) = Arr(J, zArr(Z))
Next Z
End If
Next J
If W Then
Sheets("CHI TIET").[A4].Resize(65000, 3).ClearContents
Sheets("CHI TIET").[A4].Resize(W, 3).Value = dArr()
End If
End Sub
[/GPECODE]

cảm ơn bạn đã chia sẻ, mình vừa làm được rồi, hi

giangleloi · 20/7/15

hpkhuong đã viết:
Name động làm list cho Source:

Mã:

=OFFSET([COLOR=#ff0000][B]Sheet1!$A$2,[/B][/COLOR],,COUNTA([COLOR=#ff0000]Sheet1!$A$2[/COLOR]:$A$1000))

Sheet1!$A$2: màu đỏ này bạn chỉnh cho đúng tên sheet thực tế mới thêm của bạn

Thế thì xài code để tạo Name luôn. Kiểu như thế này nè:

Mã:

Sub LOCNCC()
Dim Rng As Range
  Sheet1.Columns(4).Copy: Sheet3.[D1].PasteSpecial xlPasteValues
    With Sheet3
      .Columns(4).RemoveDuplicates Columns:=1, Header:=xlYes
      Set Rng = .Range("D2:D" & .Range("D" & Rows.Count).End(3).Row)
    ActiveWorkbook.Names.Add "NCC", Rng
    End With
End Sub

doveandrose · 20/7/15

giangleloi đã viết:
Thế thì xài code để tạo Name luôn. Kiểu như thế này nè:

Mã:

Sub LOCNCC() Dim Rng As Range Sheet1.Columns(4).Copy: Sheet3.[D1].PasteSpecial xlPasteValues With Sheet3 .Columns(4).RemoveDuplicates Columns:=1, Header:=xlYes Set Rng = .Range("D2:D" & .Range("D" & Rows.Count).End(3).Row) ActiveWorkbook.Names.Add "NCC", Rng End With End Sub

đã dùng code mà còn bị tốn 1 vùng trên sheet để lưu danh sách (tấc đất tấc vàng), rồi tốn thêm 1 named để đặt tên cho cái vùng đó nữa => chưa đi đến bến bờ ăn chơi )(&&@@

có cách nào thực hiện bằng code đúng như hình vẽ #10 không ta ? List Source hiện lên chính xác
NCC1,NCC2,NCC3

phihndhsp · 20/7/15

hpkhuong đã viết:
Cũng có suy nghỉ như bác vậy. Tốn đất.......... Mà nếu không có đất cắm dùi thì biết để ở đâu? Bác gán trực tiếp vào Source như hình vẽ được không? Hay ta thử record thao tác này xem................hihi

đừng tìm nữa? không có cách nào đâu, phải thông qua cái name thì mới được(theo như hiểu biết của tôi)

doveandrose · 20/7/15

phihndhsp đã viết:
đừng tìm nữa? không có cách nào đâu, phải thông qua cái name thì mới được(theo như hiểu biết của tôi)

em chém gió chơi chứ thật ra em cũng đâu biết làm =))
nhưng em biết chắc 1 điều
khi topic này kết thúc thì hiểu biết của anh sẽ khác đi đấy =))

phihndhsp · 20/7/15

cũng hy vọng là vậy. vì trước đây mấy năm tôi cũng hỏi mà chưa có câu trả lời cho validation lấy từ nguồn dữ liệu ra duy nhất

n0thing1988 · 20/7/15

Chủ đề đang hay. Liệu có ai giải đáp được thắc mắc của thầy Phi ko?
Đặt gạch hóng tiếp

giangleloi · 20/7/15

doveandrose đã viết:
em chém gió chơi chứ thật ra em cũng đâu biết làm =))
nhưng em biết chắc 1 điều
khi topic này kết thúc thì hiểu biết của anh sẽ khác đi đấy =))

Và code nó ở đây ( Hic hic hic)

huypham · 20/7/15

Code chuẩn luôn. Nhưng nên đặt tên là Hahaha --=0

phihndhsp · 20/7/15

phihndhsp đã viết:
cũng hy vọng là vậy. vì trước đây mấy năm tôi cũng hỏi mà chưa có câu trả lời cho validation lấy từ nguồn dữ liệu ra duy nhất

Đúng là có người bàn và vấn đề đã ra, không cần tạo name, đúng là 1 nhóm người cùng suy nghĩ có khác
sửa lại code bài 35 một tí, dùng dic lấy duy nhất sau đó đưa vào trong validation

Mã:

Public Sub LIST()
Dim Dic As Object, Arr(), I As Long, TEM As String, K As Long
Dim rng As Range
    Application.ScreenUpdating = False
    Set Dic = CreateObject("Scripting.Dictionary")
    DONGCUOI = Sheet1.Range("D65000").End(xlUp).Row
    Set rng = Sheet1.Range("D2:D" & DONGCUOI)
    ReDim Arr(1 To DONGCUOI)
    For I = 1 To DONGCUOI - 1
               TEM = rng(I, 1)
            If Not Dic.Exists(TEM) Then
                K = K + 1
                Dic.Add TEM, K
                Arr(K) = rng(I, 1).Value
            End If
    Next I
    TEM = Join(Arr, ",")
    For I = K To DONGCUOI
        TEM = Replace(TEM, ",,", ",")
    Next
    TEM = Left(TEM, Len(TEM) - 1)
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=TEM
    End With
        Application.ScreenUpdating = true
End Sub

giangleloi · 20/7/15

phihndhsp đã viết:
Đúng là có người bàn và vấn đề đã ra, không cần tạo name, đúng là 1 nhóm người cùng suy nghĩ có khác
sửa lại code bài 35 một tí, dùng dic lấy duy nhất sau đó đưa vào trong validation

Mã:

For I = K To DONGCUOI TEM = Replace(TEM, ",,", ",") Next

Em cũng làm theo hướng của anh luôn rồi. Nhưng cố đợi anh chàng cao siêu đó hỏi "đểu" nữa. "Người ấy" không phải dạng vừa. Hình như đoạn trên đấy không cần anh nhỉ? Chỉ vô Source mới thấy. Bên ngoài thì đâu ảnh hưởng )(&&@@

phihndhsp · 20/7/15

Vì chưa xác định chiều dài của mảng một chiều nên tôi lấy chiều dài dài nhất, và khi dùng hàm join nó sẽ thêm nhiều dấu ,,, nên cần xử lý những chuỗi ,, lại

Kiều Mạnh · 20/7/15

phihndhsp đã viết:

Đúng là có người bàn và vấn đề đã ra, không cần tạo name, đúng là 1 nhóm người cùng suy nghĩ có khác
sửa lại code bài 35 một tí, dùng dic lấy duy nhất sau đó đưa vào trong validation

Mã:

Public Sub LIST()
Dim Dic As Object, Arr(), I As Long, TEM As String, K As Long
Dim rng As Range
    Application.ScreenUpdating = False
    Set Dic = CreateObject("Scripting.Dictionary")
    DONGCUOI = Sheet1.Range("D65000").End(xlUp).Row
    Set rng = Sheet1.Range("D2:D" & DONGCUOI)
    ReDim Arr(1 To DONGCUOI)
    For I = 1 To DONGCUOI - 1
               TEM = rng(I, 1)
            If Not Dic.Exists(TEM) Then
                K = K + 1
                Dic.Add TEM, K
                Arr(K) = rng(I, 1).Value
            End If
    Next I
    TEM = Join(Arr, ",")
    For I = K To DONGCUOI
        TEM = Replace(TEM, ",,", ",")
    Next
    TEM = Left(TEM, Len(TEM) - 1)
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=TEM
    End With
        Application.ScreenUpdating = true
End Sub

Nếu chỉ Add mỗi cái Validation thì xài code sau đi cho nó gọn

PHP:

Public Sub DicAdd_Validation()
    Dim dl(), i As Long, Dic As Object
    dl = Range([D2], [D65536].End(3)).Value
    Set Dic = CreateObject("scripting.dictionary")
       For i = 1 To UBound(dl)
            Dic(dl(i, 1)) = ""
       Next
       Range("G2").Validation.Delete
       Range("G2").Validation.Add 3, , , Join(Dic.keys, ",")
    Set Dic = Nothing
End Sub

doveandrose · 20/7/15

phihndhsp đã viết:
Vì chưa xác định chiều dài của mảng một chiều nên tôi lấy chiều dài dài nhất, và khi dùng hàm join nó sẽ thêm nhiều dấu ,,, nên cần xử lý những chuỗi ,, lại

nhìn phần chữ kí của anh chắc là anh ít xài Dic nên mới nghĩ và làm thế . còn anh nhìn chữ kí của em chắc cũng biết em thích tắm cái giếng nào . hihi . đâu cần phải khỗ vậy . nhờ anh và các bạn ở trên giúp đỡ , em mới nghĩ ra được cách này . cám ơn các bạn

Mã:

Public Sub hello()
Dim Dic As Object, Arr As Variant, lr As Long, r As Long
    Application.ScreenUpdating = False
    Set Dic = CreateObject("Scripting.Dictionary")
    lr = WorksheetFunction.Max(Sheet1.Range("D65000").End(xlUp).Row, 2)
    Arr = Sheet1.Range("D2:D" & lr).Value
    If IsArray(Arr) Then
        For r = 1 To lr - 1
            If WorksheetFunction.Trim(Arr(r, 1)) <> "" Then Dic(Arr(r, 1)) = 1
        Next
    Else
        If WorksheetFunction.Trim(Arr) <> "" Then Dic(Arr) = 1
    End If
    Sheet1.Range("G2").ClearContents
    With Sheet1.Range("G2").Validation
        .Delete
        If Dic.Count > 0 Then
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=Join(Dic.keys(), ",")
        End If
    End With
    Application.ScreenUpdating = True
End Sub

giangleloi · 20/7/15

Thêm 1 cách không xài DIC nè:

Mã:

Sub List_HICHICHIC()
Application.ScreenUpdating = False
Dim Lr As Long, Str As String, I As Long
  With Sheet1
    Lr = .Range("D" & Rows.Count).End(xlUp).Row
    For I = 2 To Lr
       If .Application.WorksheetFunction.CountIf(.Range("D2:D" & I), .Range("D" & I)) = 1 Then
             Str = Str & "," & .Range("D" & I)
        End If
    Next
    With .[G2].Validation
        .Delete
        .Add 3, , ,Str
    End With
 End With
Application.ScreenUpdating = True
End Sub

Kiều Mạnh · 20/7/15

doveandrose đã viết:
nhìn phần chữ kí của anh chắc là anh ít xài Dic nên mới nghĩ và làm thế . còn anh nhìn chữ kí của em chắc cũng biết em thích tắm cái giếng nào . hihi . đâu cần phải khỗ vậy . nhờ anh và các bạn ở trên giúp đỡ , em mới nghĩ ra được cách này . cám ơn các bạn

Mã:

Public Sub hello() Dim Dic As Object, Arr As Variant, lr As Long, r As Long Application.ScreenUpdating = False Set Dic = CreateObject("Scripting.Dictionary") lr = WorksheetFunction.Max(Sheet1.Range("D65000").End(xlUp).Row, 2) Arr = Sheet1.Range("D2:D" & lr).Value If IsArray(Arr) Then For r = 1 To lr - 1 If WorksheetFunction.Trim(Arr(r, 1)) <> "" Then Dic(Arr(r, 1)) = 1 Next Else If WorksheetFunction.Trim(Arr) <> "" Then Dic(Arr) = 1 End If Sheet1.Range("G2").ClearContents With Sheet1.Range("G2").Validation .Delete If Dic.Count > 0 Then .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=Join(Dic.keys(), ",") End If End With Application.ScreenUpdating = True End Sub

Tám một tẹo
hình như Bạn cũng mê Dic giống mình thì phải .....có thì cứ lôi ra mà xài đi cho sướng vậy cất dấu để rành mằn chi ....khổ quá đi mất.. --=0

doveandrose · 20/7/15

kieu manh đã viết:
Tám một tẹo
hình như Bạn cũng mê Dic giống mình thì phải .....có thì cứ lôi ra mà xài đi cho sướng vậy cất dấu để rành mằn chi ....khổ quá đi mất..

cái đó đương nhiên rồi . em đoán là chức năng remove Duplicate của excel cũng hoạt động theo nguyên tắc này .
khi các bạn từng thử nghiệm lấy danh sách duy nhất với cỡ khoảng hàng trăm nghìn mã số khác nhau thì có lẽ các bạn sẽ dẹp bỏ được ý nghĩ : lấy danh sách không trùng mà không cần dùng Dic hoặc chức năng remove duplicate
còn anh nữa : bài viết của anh có 4 chữ số rồi sao vẫn các ngôi sao quay đều vậy ? phải bao nhiêu bài viết mới được 1 sao đứng im vậy ?

giangleloi · 20/7/15

doveandrose đã viết:
còn anh nữa : bài viết của anh có 4 chữ số rồi sao vẫn các ngôi sao quay đều vậy ? phải bao nhiêu bài viết mới được 1 sao đứng im vậy ?

Hình như là 1100 hay 1200 lận ấy. Muốn làm gạo cội luôn rùi hỉ. --=0

Kiều Mạnh · 20/7/15

doveandrose đã viết:
cái đó đương nhiên rồi . em đoán là chức năng remove Duplicate của excel cũng hoạt động theo nguyên tắc này .
khi các bạn từng thử nghiệm lấy danh sách duy nhất với cỡ khoảng hàng trăm nghìn mã số khác nhau thì có lẽ các bạn sẽ dẹp bỏ được ý nghĩ : lấy danh sách không trùng mà không cần dùng Dic hoặc chức năng remove duplicate
còn anh nữa : bài viết của anh có 4 chữ số rồi sao vẫn các ngôi sao quay đều vậy ? phải bao nhiêu bài viết mới được 1 sao đứng im vậy ?

Bạn vào link sau mà tìm hiểu sao nha
[url]http://www.giaiphapexcel.com/forum/showthread.php?65521-%C4%90%E1%BB%91-v%E1%BB%81-%C3%BD-ngh%C4%A9a-c%C3%A1c-sao-v%C3%A0-c%C3%A1c-Title-c%E1%BB%A7a-GPE-qua-th%C6%A1[/URL]

doveandrose · 20/7/15

giangleloi đã viết:
Hình như là 1100 hay 1200 lận ấy. Muốn làm gạo cội luôn rùi hỉ.

tôi không nghĩ cuộc đời tôi có cái ngày đó . tôi chỉ quan tâm công việc hàng ngày của mình . lúc nào rảnh mới vào đây kiếm tụ điểm ăn chơi vào hỏi xoáy đáp xoay thôi .

Lọc mảng nhiều điều kiện

Thành viên mới

Thành viên gắn bó

hello

Thành viên gạo cội

hello

Thành viên gạo cội

Mù VBA

Thành viên gắn bó

File đính kèm

Thành viên mới

Thành viên gạo cội

File đính kèm

Thành viên gắn bó

Thành viên gạo cội

I don't program, I beat code into submission!!!

hello

Thành viên gắn bó

I don't program, I beat code into submission!!!

hello

Thành viên gắn bó

I don't program, I beat code into submission!!!

hello

Đếm ngược thời gian