Vấn đề về Dictionary.

[Thanhlam2425]

Mọi người cho mình hỏi.Trong dictionary có tìm kiếm tương đối không ạ.
Ví dụ như hàm INSTR,hoặc hàm Like. Đấy ạ.

 

[Thanhlam2425]

@Thanhlam2425

Sub Instr_Like()
Dim Arr0, Arr1, i
On Error Resume Next
Arr0 = Sheet1.Range("a1").CurrentRegion
Arr1 = Sheet1.Range("d1").CurrentRegion
With CreateObject("Scripting.dictionary")
    For i = 2 To UBound(Arr1)
        .Item(Arr1(i, 1)) = ""
    Next i
    For i = 2 To UBound(Arr0)
        .Remove Arr0(i, 1)
    Next i
    Sheet1.Range("g1") = .Count
    Sheet1.Range("g2").Resize(.Count, 1) = Application.Transpose(.keys)
End With
End Sub

Mình muốn kết quả như thế này nhưng mà nó nhanh hơn à.

Sub Instr_Like()
Dim Arr0, Arr1, i, j, chuoi As String, ketqua, k As Long
On Error Resume Next
Arr0 = Sheet1.Range("a1").CurrentRegion
Arr1 = Sheet1.Range("d1").CurrentRegion
ReDim ketqua(1 To UBound(Arr0), 1 To 1)
    For i = 2 To UBound(Arr0)
        chuoi = chuoi & "#" & Arr0(i, 1)
    Next i
    For i = 2 To UBound(Arr1)
        If InStr(1, chuoi, Arr1(i, 1)) = 0 Then
           k = k + 1
           ketqua(k, 1) = Arr1(i, 1)
        End If
    Next i
    Sheet1.Range("F2:F100000").ClearContents
    If k Then Sheet1.Range("F2").Resize(k) = ketqua
End Sub

 

[tam888]

Mình muốn kết quả như thế này nhưng mà nó nhanh hơn à.

Sub Instr_Like()
Dim Arr0, Arr1, i, j, chuoi As String, ketqua, k As Long
On Error Resume Next
Arr0 = Sheet1.Range("a1").CurrentRegion
Arr1 = Sheet1.Range("d1").CurrentRegion
ReDim ketqua(1 To UBound(Arr0), 1 To 1)
    For i = 2 To UBound(Arr0)
        chuoi = chuoi & "#" & Arr0(i, 1)
    Next i
    For i = 2 To UBound(Arr1)
        If InStr(1, chuoi, Arr1(i, 1)) = 0 Then
           k = k + 1
           ketqua(k, 1) = Arr1(i, 1)
        End If
    Next i
    Sheet1.Range("F2:F100000").ClearContents
    If k Then Sheet1.Range("F2").Resize(k) = ketqua
End Sub

Túm lại bạn muốn kết quả gần đúng hay chính xác
Nghĩa là data 1 ô cột D là 1 phần trong ô cột A--> là lấy? hay chính xác?

 

[CHAOQUAY]

Mình muốn kết quả như thế này nhưng mà nó nhanh hơn à.

Vậy là kết quả đúng rồi à
Chỉ là đang chậm thôi à

 

[HieuCD]

Mình muốn kết quả như thế này nhưng mà nó nhanh hơn à.

Sub Instr_Like()
Dim Arr0, Arr1, i, j, chuoi As String, ketqua, k As Long
On Error Resume Next
Arr0 = Sheet1.Range("a1").CurrentRegion
Arr1 = Sheet1.Range("d1").CurrentRegion
ReDim ketqua(1 To UBound(Arr0), 1 To 1)
    For i = 2 To UBound(Arr0)
        chuoi = chuoi & "#" & Arr0(i, 1)
    Next i
    For i = 2 To UBound(Arr1)
        If InStr(1, chuoi, Arr1(i, 1)) = 0 Then
           k = k + 1
           ketqua(k, 1) = Arr1(i, 1)
        End If
    Next i
    Sheet1.Range("F2:F100000").ClearContents
    If k Then Sheet1.Range("F2").Resize(k) = ketqua
End Sub

Rút gọn code của bạn, tốc độ chấp nhận được

Sub Instr_Like()
  Dim sArr(), Res(), i As Long, k As Long, tmp As String

  sArr = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  tmp = Join(Application.Transpose(sArr), "#")
  sArr = Range("D2", Range("D" & Rows.Count).End(xlUp)).Value
  ReDim Res(1 To UBound(sArr), 1 To 1)
  For i = 1 To UBound(sArr)
    If InStr(1, tmp, sArr(i, 1)) = 0 Then
      k = k + 1
      Res(k, 1) = sArr(i, 1)
    End If
  Next i
  Range("F2:F100000").ClearContents
  If k Then Range("F2").Resize(k) = Res
End Sub

 

[tam888]

Mình muốn kết quả như thế này nhưng mà nó nhanh hơn à.

Sub Instr_Like()
Dim Arr0, Arr1, i, j, chuoi As String, ketqua, k As Long
On Error Resume Next
Arr0 = Sheet1.Range("a1").CurrentRegion
Arr1 = Sheet1.Range("d1").CurrentRegion
ReDim ketqua(1 To UBound(Arr0), 1 To 1)
    For i = 2 To UBound(Arr0)
        chuoi = chuoi & "#" & Arr0(i, 1)
    Next i
    For i = 2 To UBound(Arr1)
        If InStr(1, chuoi, Arr1(i, 1)) = 0 Then
           k = k + 1
           ketqua(k, 1) = Arr1(i, 1)
        End If
    Next i
    Sheet1.Range("F2:F100000").ClearContents
    If k Then Sheet1.Range("F2").Resize(k) = ketqua
End Sub

Nếu thế nên thử dùng Filter là nhanh (có thể tôi nhầm, áp dụng bài viết trên)

 

[Thanhlam2425]

Rút gọn code của bạn, tốc độ chấp nhận được

Sub Instr_Like()
  Dim sArr(), Res(), i As Long, k As Long, tmp As String

  sArr = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  tmp = Join(Application.Transpose(sArr), "#")
  sArr = Range("D2", Range("D" & Rows.Count).End(xlUp)).Value
  ReDim Res(1 To UBound(sArr), 1 To 1)
  For i = 1 To UBound(sArr)
    If InStr(1, tmp, sArr(i, 1)) = 0 Then
      k = k + 1
      Res(k, 1) = sArr(i, 1)
    End If
  Next i
  Range("F2:F100000").ClearContents
  If k Then Range("F2").Resize(k) = Res
End Sub

Cảm ơn Anh Hiếu ạ.