Nhờ Giúp đỡ dictionary (1 người xem)

[ducthao5]

Hiện tại em có sheet dữ liệu 50.000 dòng nhưng muốn lấy danh mục duy nhất cột A và cột D, không lấy cột B và C, đưa dữ liệu vào cột I và cột J duy nhất không trùng lặp bằng cách dùng scipt dictionary. Mong các anh chị hỗ trợ giúp em code đơn giản nhất.

 

[ducthao5]

Muốn nhờ các cao thủ chỉ để học hỏi luôn, còn nhiều vấn đề nữa chứ, Nếu dữ liệu lớn thì làm thế nào ? mong các anh chị hỗ trợ giùm

 

[Hai Lúa Miền Tây]

Hiện tại em có sheet dữ liệu 50.000 dòng nhưng muốn lấy danh mục duy nhất cột A và cột D, không lấy cột B và C, đưa dữ liệu vào cột I và cột J duy nhất không trùng lặp bằng cách dùng scipt dictionary. Mong các anh chị hỗ trợ giúp em code đơn giản nhất.

Dùng advanced filter cũng được. Tôi ghi lại động tác và được code như sau:

Sub Macro1()
'
' Macro1 Macro
'

'
    
    Range("A1:D50000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "I1:J1"), Unique:=True
End Sub

 

[ducthao5]

Có bác nào dùng scipt dictionary không cho em xin chỉ giáo với, chứ các cái này em cũng nắm rồi. Mong hướng dẫn code bằng scipt dictionary

 

[PacificPR]

Máy em Record Macro nó ra vầy:

Sub Macro1()
'
' Macro1 Macro
'
    Dim Dic As Object, sArr(), dArr(), I As Long, K As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    sArr = .Range("A2", .Range("A65535").End(3)).Resize(, 4).Value
    ReDim dArr(1 To UBound(sArr, 1), 1 To 2)
    For I = 1 To UBound(sArr, 1)
        Tem = sArr(I, 1) & "#" & sArr(I, 4)
        If Not Dic.Exists(Tem) Then
            K = K + 1
            Dic.Add Tem, K
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = sArr(I, 4)
        End If
    Next I
    .Range("I2").Resize(K, 2) = dArr
End With
Set Dic = Nothing
End Sub

 

[ducthao5]

chạy báo lỗi nhờ bá kiểm tra lại

 

[PacificPR]

chạy báo lỗi nhờ bá kiểm tra lại
View attachment 182234

Sao máy em nó vẫn chạy bình thường

 

[Hai Lúa Miền Tây]

Máy em Record Macro nó ra vầy:

Sub Macro1()
'
' Macro1 Macro
'
    Dim Dic As Object, sArr(), dArr(), I As Long, K As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    sArr = .Range("A2", .Range("A65535").End(3)).Resize(, 4).Value
    ReDim dArr(1 To UBound(sArr, 1), 1 To 2)
    For I = 1 To UBound(sArr, 1)
        Tem = sArr(I, 1) & "#" & sArr(I, 4)
        If Not Dic.Exists(Tem) Then
            K = K + 1
            Dic.Add Tem, K
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = sArr(I, 4)
        End If
    Next I
    .Range("I2").Resize(K, 2) = dArr
End With
Set Dic = Nothing
End Sub

Bình thường thì máy mình nó tự cho ra cái code như sau:

Sub Macro1()
'
' Macro1 Macro
'

'
    Dim cn As Object
    Set cn = CreateObject("ADODB.Connection")
    cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";")
    [I2].CopyFromRecordset cn.Execute("SELECT DISTINCT F1,F4 FROM [Sheet1$A2:D50000] WHERE F1 IS NOT NULL")
   
End Sub

P/s: Chỉ giải thích là máy mình nó ra như vậy, có thể không đúng yêu cầu của chủ thớt, nhưng kết quả có thể đúng yêu cầu.

 

[ducthao5]

Cảm ơn nhiều, Em đã hiểu nguyên lý của nó.

 

[VetMini]

Máy em Record Macro nó ra vầy:

    For I = 1 To UBound(sArr, 1)
        Tem = sArr(I, 1) & "#" & sArr(I, 4)
        If Not Dic.Exists(Tem) Then
            K = K + 1
            Dic.Add Tem, K
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = sArr(I, 4)
        End If
    Next I

Tôi chả hiểu tại sao quý vị lại thích cái tên Tem đến thế. Nói thẳng, đó là một thói quen không tốt.
Ở đây, bạn muốn dựng một cái Key, đặt là khoa, hay myKey có phải dễ nhìn hơn không.

Có bác nào dùng scipt dictionary không cho em xin chỉ giáo với, chứ các cái này em cũng nắm rồi. Mong hướng dẫn code bằng scipt dictionary

Đề bài này không phải là một ví dụ tốt để tập dùng Dictionary. Vả lại, ở trình độ của bạn thì nên chú tâm học gõ đúng từ khoá thì tốt hơn.

 

[Hai Lúa Miền Tây]

Máy mấy bạn ở trên hay quá..., máy mình nó ra vậy nè:

Option Explicit

Sub Macro1()
'
' Macro1 Macro
'

'
    Range("A:A,D:D").Select
    Range("D1").Activate
    Selection.Copy
    Columns("I:J").Select
    ActiveSheet.Paste
    Columns("I:J").Select
    ActiveSheet.Range("$I$1:$J$68").RemoveDuplicates Columns:=Array(1, 2), Header _
        :=xlNo
End Sub

Không hiểu sao, máy của mình sao nó chạy ra như sau:

Sub Macro2()
'
' Macro2 Macro
'

'
    Range("A:A,D:D").Copy [I1]
    Range("I:J").RemoveDuplicates Columns:=Array(1, 2)
End Sub

 

[ducthao5]

có cách nào mình khai cả 2 item vào trong dic sau đó mình lấy dữ liệu ra không nhỉ ? Có anh Hướng dẫn mình gán như sau :

TmpArr1 = shDuLieu.Range("A1:D" & CStr(iLastRow)).Value


For iRow = 1 To UBound(TmpArr1, 1)

    If Not Dic1.exists(Trim(TmpArr1(iRow, 1)) & Trim(TmpArr1(iRow, 4)) ) Then

            i = i + 1

            Dic1.Add Trim(TmpArr1(iRow, 1)) & Trim(TmpArr1(iRow, 4)) , i  'Dua key phuc hop vao Dic.

            ................

   Else

            j = Dic1.Item(Trim(TmpArr1(iRow, 1)) & Trim(TmpArr1(iRow, 4))) 'lay thu tu dong cua gia tri key trung

            ........

   End If

Next iRow

ActiveSheet.Range("A1").Resize(i, j).Value = arr

Có bác nào giải thích cho em nếu gán thế có lấy được dữ liệu hay không vậy ??