Giúp viết code dò tìm và nối chuỗi

Chia sẻ bởi:hands

★★★★★

‹ Giúp sửa code: Dùng Find Method để... Giúp sửa code: hàm Month và nối... ›

Quảng cáo

Em chào Thầy cô và anh chị!
Giúp em viết code dò tìm và nối chuỗi như sau:
Code cho kết qủa từ Cell J9 trở xuống tại Sheet TH:
Tại J9 em có cthức như sau:
=IF(B9<>"";(VLOOKUP(H9&I9;DG;2;0)&" "&G9&"_"&F9);"")
Trong đó DG là name của sheet MA
=Ma!$L$5:$N$19
Vì dữ liệu của em rất nhiều nên giúp em viết code dưới dạng mảng
Trong bài của em cột B của Sheet TH là liên tục!
Em cũng đã làm nhưng vẫn chưa được, vì vậy mong Thầy cô & anh chị giúp. Xin cảm ơn!

Bạn tham khảo Code này nhé

Sub Timkiem()
Dim ArrPN, ArrData, DicArrPN, Dic As Object, i, k  As Integer

ArrPN = Sheet1.Range("L5:M" & Range("M65536").End(3).Row)
ArrData = Sheet2.Range("A9:J" & Range("B65536").End(3).Row)
ReDim DicArrPN(1 To UBound(ArrPN, 1), 1 To 2)

Set Dic = CreateObject("Scripting.Dictionary")

With Dic
    For i = 1 To UBound(ArrPN, 1)
        If Not .exists(ArrPN(i, 1)) Then 'Gan Item cho Dic
            k = k + 1
            .Add ArrPN(i, 1), k
            DicArrPN(k, 1) = ArrPN(i, 1) 'Dua du lieu vao DicArrPN
            DicArrPN(k, 2) = ArrPN(i, 2)
        End If
    Next
'Truy xuat tu Arrdata toi Dic
    For i = 1 To UBound(ArrData, 1)
        If ArrData(i, 2) <> "" And .exists(ArrData(i, 8) & ArrData(i, 9)) Then
            ArrData(i, 10) = DicArrPN(.Item(ArrData(i, 8) & ArrData(i, 9)), 2) & " " & ArrData(i, 7) & " " & ArrData(i, 6)
        End If
    Next
End With

'Xuat vung Data ra Sheets("TH")
Sheet2.[a9].Resize(UBound(ArrData), 10) = ArrData

End Sub

www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-vi%E1%BA%BFt-code-d%C3%B2-t%C3%ACm-v%C3%A0-n%E1%BB%91i-chu%E1%BB%97i.75777/

Sao lại làm vậy, với dữ liệu đã có thì copy rồi PasteSpeacial là xong. Còn dữ liệu mới thì áp dụng WorkSheet_Change mà điền dữ liệu, như vậy chỉ có 1 ô thôi nên không có cảm giác về tốc độ đâu. Nhập đến đâu điền đến đó vậy là ổn

Dùng Find Method đây:

Sub Test()
  Dim Find_Table As Range, aSrcData, rFind As Range
  Dim lR As Long
  Dim sTmp As String, sFindVal As String, sRes As String
  On Error Resume Next
  Set Find_Table = Sheets("Ma").Range("L5:M20000")
  With Sheets("TH").Range("B9:J20000")
    aSrcData = .Value
    For lR = 1 To UBound(aSrcData, 1)
      sTmp = CStr(aSrcData(lR, 1))
      If Len(sTmp) Then
        sFindVal = aSrcData(lR, 7) & aSrcData(lR, 8)
        Set rFind = Find_Table.Find(sFindVal, , xlValues, xlWhole)
        If Not rFind Is Nothing Then
          sRes = rFind.Offset(, 1).Value
          aSrcData(lR, 9) = sRes & " " & aSrcData(lR, 6) & "_" & aSrcData(lR, 5)
        End If
      End If
    Next
    .Value = aSrcData
  End With
End Sub

Chỉ có 1/2 là mảng thôi

www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-vi%E1%BA%BFt-code-d%C3%B2-t%C3%ACm-v%C3%A0-n%E1%BB%91i-chu%E1%BB%97i.75777/post-465299

www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-vi%E1%BA%BFt-code-d%C3%B2-t%C3%ACm-v%C3%A0-n%E1%BB%91i-chu%E1%BB%97i.75777/post-465299
Theo mình nếu để điền toàn bộ diễn giải có lẽ thế này là được, thậm chí tối ưu về tốc độ là đằng khác

Sub Reset_Data()
Dim Buttoan, PSinh, Dgiai(), i, Dic As Object
Buttoan = Sheet1.Range("L5:M" & Sheet1.Range("M65536").End(3).Row)
PSinh = Sheet2.Range("A9:J" & Sheet2.Range("B65536").End(3).Row)
ReDim Dgiai(1 To UBound(PSinh, 1), 1 To 1)
Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Buttoan, 1)
      If Not Dic.exists(Trim(Buttoan(i, 1))) Then Dic.Add Trim(Buttoan(i, 1)), Buttoan(i, 2)
    Next
 On Error Resume Next
 For i = 1 To UBound(PSinh, 1)
     If PSinh(i, 2) <> 0 Then Dgiai(i, 1) = Dic.Item(PSinh(i, 8) _
     & PSinh(i, 9)) & " " & PSinh(i, 7) & IIf(PSinh(i, 6) <> "", "_" & PSinh(i, 6), "")
  Next
  Sheet2.[J9].Resize(UBound(Dgiai, 1)) = Dgiai
  Set Dic = Nothing
End Sub

www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-vi%E1%BA%BFt-code-d%C3%B2-t%C3%ACm-v%C3%A0-n%E1%BB%91i-chu%E1%BB%97i.75777/post-465397

Em thấy mấy bài Dic gần như giải quyết hầu hết các bài khó
Em cũng đã đọc một số bài như Ðề tài: [URL='https://www.giaiphapexcel.com/forum/showthread.php?60643-T%E1%BB%95ng-quan-v%E1%BB%81-Scripting-Dictionary']Tổng quan về Scripting.Dictionary

và một số bài khác, nhưng cũng chưa hiểu gì nhiều!
Thầy cô & các Anh giúp em giải thích code trên để em hiểu hơn!
Em cảm ơn!

Đối với Code bài này thì không có gì để nói nhiều, chỉ có vấn đề dùng Dictionary. Không phải Dictionary giải quyết được mọi vấn đề khó, mà là ta lợi dụng thế mạnh của nó phục vụ mục đích của mình mà thôi. Yêu cầu chính của bài là tra mã định khoản để lấy Diễn giải (Tiếp đầu ngữ). Với các hàm Vlookup, Match, hay cấu trúc For…Next… hay phương thức Find thực chất là vẫn rà từ đầu Danh sách đến khi gặp mã thì lấy. Trong khi đó, Dic. nó có phương thức: Dic.Item(Key) thì nó trả về Item của Key. Nói gọn lại, là lấy đích danh chứ không phải dò tìm nữa, giống như như mảng Arr(n) ta lấy Arr(3) chẳng hạn. Vậy là tốc độ tăng lên rất nhiều. Đây là chiêu mình rất thích dùng cho các bài toán xuất nhập tồn, công nợ hay tổng hợp phát sinh Tài khoản kế toán. Đảm bảo nó nhanh và chính xác hơn các cách khác nhiều.

Ngoài Dictionary, nhiều khi người ta còn dùng Listview để sử lý nữa vì nó cơ chế tìm kiếm Find riêng và khả năng Sort dữ liệu theo cột. Việc sử dụng Listview cũng theo phương thức CreateObject mà AnhTuan1066 đã có bài tương tự về Combobox rồi. Khi nào có dịp ta tìm hiểu thêm.

GIÚP EM SỬA CODE CỦA CỘT J CỦA SHEET TH
—————————-
Code cũ của em
Sub DienGiai_Old()
    Dim i As Long
    Dim arrRes, arrSrc
    Dim n1 As Range, rTmp As Range

With ActiveSheet
        arrSrc = .Range(.[B9], .[B65536].End(3)).Resize(, 11).Value
    End With

With Sheets("MA")
        Set n1 = .Range(.[L5], .[L200].End(3))
    End With
    ReDim arrRes(1 To UBound(arrSrc, 1), 1 To 1)
    For i = 1 To UBound(arrSrc, 1)
        Set rTmp = n1.Find(arrSrc(i, 7) & arrSrc(i, 8), , xlValues, xlWhole)
        If Not rTmp Is Nothing Then
            If arrSrc(i, 7) = 1561 Or arrSrc(i, 7) = 155 Or arrSrc(i, 7) = 152 Or arrSrc(i, 7) = 153 Then

arrRes(i, 1) = rTmp.Offset(, 1) & " " & arrSrc(i, 11) & " c" & ChrW(7911) & "a " & arrSrc(i, 6)
            Else
                arrRes(i, 1) = rTmp.Offset(, 1) & " " & arrSrc(i, 11) & " cho " & arrSrc(i, 6)
            End If
        End If

Next i
    ActiveSheet.Range("J9").Resize(UBound(arrRes, 1)).Value = arrRes
End Sub
Em giải thích code trên như sau:
Ví dụ em lấy dòng 15 của Sheet TH như sau:
Ghép Cell H15 và I15 để dò tìm bên Sheet MA của cột L, nếu tìm thấy thì lấy kết qủa của cột kế bên và nối với một số cell L15 và G15 để cho kết qủa tại Cell J15
(và thêm một số điều kiện linh tinh khác)
——————-
Bây giờ code mới em như sau
Trước đây Cell G15 là tên khách hàng, bây giờ em đổi G15 là Mã KH. Vì thế trước khi nối chuỗi thì sẽ dùng G15 để tìm Bên Sheet Mã tại cột BE, nếu tìm thấy thì sẽ lệch qua cột BH để lấy kết qủa và nối chuỗi giống như trên
—————
Cụ thể code cũ chạy cho kết qủa tại cell J15 của Sheet TH là "Nhập Vỏ xe của M013"
Mà Mả KH M013 dò bên Sheet Mã là cell BE126 và sẽ lấy kết qủa cell BH126 là: "Cty TNHH DV Tân Minh Tài" và vẫn nối chuỗi như trên
Như vậy khi chạy code sẽ cho kết qủa đúng là "Nhập Vỏ xe của Cty TNHH DV Tân Minh Tài"
———–
Code mới em viết như sau
Sub DienGiai_New()
    Dim i As Long
    Dim arrRes, arrSrc
    Dim n1 As Range, rTmp As Range
    Dim n2 As Range, rTmp1 As Range
    With ActiveSheet
        arrSrc = .Range(.[B9], .[B65536].End(3)).Resize(, 11).Value
    End With

With Sheets("MA")
        Set n1 = .Range(.[L5], .[L200].End(3))
        Set n2 = .Range(.[BE10], .[BE2000].End(3))
    End With

ReDim arrRes(1 To UBound(arrSrc, 1), 1 To 1)
    For i = 1 To UBound(arrSrc, 1)
        Set rTmp = n1.Find(arrSrc(i, 7) & arrSrc(i, 8), , xlValues, xlWhole)
        Set rTmp1 = n2.Find(arrSrc(i, 6), , xlValues, xlWhole)
        If Not rTmp Or rTmp1 Is Nothing Then
            If arrSrc(i, 7) = 1561 Or arrSrc(i, 7) = 155 Or arrSrc(i, 7) = 152 Or arrSrc(i, 7) = 153 Then

arrRes(i, 1) = rTmp.Offset(, 1) & " " & arrSrc(i, 11) & " c" & ChrW(7911) & "a " & rTmp1.Offset(, 3)
            Else
                arrRes(i, 1) = rTmp.Offset(, 1) & " " & arrSrc(i, 11) & " cho " & rTmp1.Offset(, 3)
            End If
        End If
    Next i
    ActiveSheet.Range("J9").Resize(UBound(arrRes, 1)).Value = arrRes
End Sub
Nhưng code này báo lỗi, em tìm vẫn chưa tìm ra! Vì vậy em nhờ Thầy cô & anh chị giúp em sửa code trên
—————
Trong File em có 2 nút cho code cũ & mới
Em cảm ơn!
Em đã tìm ra lỗi rồi! Xin cảm ơn đã đọc bài
If Not rTmp Is Nothing Then
            If Not rTmp1 Is Nothing Then
                If arrSrc(i, 7) = 1561 Or arrSrc(i, 7) = 155 Or arrSrc(i, 7) = 152 Or arrSrc(i, 7) = 153 Then

arrRes(i, 1) = rTmp.Offset(, 1) & " " & arrSrc(i, 11) & " c" & ChrW(7911) & "a " & rTmp1.Offset(, 3)
                Else
                    arrRes(i, 1) = rTmp.Offset(, 1) & " " & arrSrc(i, 11) & " cho " & rTmp1.Offset(, 3)
                End If
            End If
        End If

Sub DienGiai_New()

Set rTmp = n1.Find(arrSrc(i, 7) & arrSrc(i, 8), , xlValues, xlWhole)
        Set rTmp1 = n2.Find(arrSrc(i, 6), , xlValues, xlWhole)
        [COLOR=#ff0000][B]If Not rTmp Or rTmp1 Is Nothing Then[/B][/COLOR]

End Sub

Sai chổ màu đỏ
Sửa thành: If (Not rTmp Is Nothing) And (Not rTmp1 Is Nothing) Then nhé
Not rTmp Is Nothing (đ/k1) nghĩa là tìm thấy rTmp
Not rTmp1 Is Nothing (đ/k2) nghĩa là tìm thấy rTmp1
Cả 2 vế này phải cùng =TRUE thì mới làm các code bên dưới
Tức IF đ/k1 and đ/k2 then —> Đúng chứ