Nhờ anh/chị giúp code tìm kiếm chuỗi ký tự

[Erebus]

Hiện tại em đang có một bài toán khó là cần tìm chuỗi trong chuỗi,
Tìm các giá trị của chuỗi 1, nếu xuất hiện trong chuỗi 2 thì trả về kết quả
Chi tiết như tệp em đính kèm.
Nhờ anh/chị giúp đỡ ạ.

 

[bebo021999]

Xài đỡ cái này:

Option Explicit
Sub test()
Dim lr&, i&, j&, k&, rng1, rng2, arr(1 To 100000, 1 To 2)
lr = Cells(Rows.Count, "B").End(xlUp).Row
rng1 = Range("B4:B" & lr).Value
rng2 = Range("E4:E7").Value
For i = 1 To UBound(rng2)
    For j = 1 To UBound(rng1)
        If InStr(1, rng1(j, 1), rng2(i, 1)) Then
            k = k + 1
            arr(k, 1) = rng2(i, 1)
            arr(k, 2) = rng1(j, 1)
        End If
    Next
Next
Range("I4:I10000").ClearContents
Range("I4").Resize(k, 2).Value = arr
End Sub

 

[Erebus]

Xài đỡ cái này:

Option Explicit
Sub test()
Dim lr&, i&, j&, k&, rng1, rng2, arr(1 To 100000, 1 To 2)
lr = Cells(Rows.Count, "B").End(xlUp).Row
rng1 = Range("B4:B" & lr).Value
rng2 = Range("E4:E7").Value
For i = 1 To UBound(rng2)
    For j = 1 To UBound(rng1)
        If InStr(1, rng1(j, 1), rng2(i, 1)) Then
            k = k + 1
            arr(k, 1) = rng2(i, 1)
            arr(k, 2) = rng1(j, 1)
        End If
    Next
Next
Range("I4:I10000").ClearContents
Range("I4").Resize(k, 2).Value = arr
End Sub

Ngay lập tức bài toán khó của em đã được giải quyết rồi ạ.
Em cảm ơn bác rất nhiều ạ

 

[SA_DQ]

Có thể tham khảo thêm 1 giải thuật rùa:

Sub TimKiemCacChuoiKyTuTrongBang()
 Dim Rws As Long, W As Long, J As Long
 Dim  Rng As Range, sRng As Range
 Dim MyAdd As String, GTTim As String
 
 Set Rng = [B4].CurrentRegion
 Rws = Rng.Rows.Count * [E4].CurrentRegion.Rows.Count
 ReDim Arr(1 To Rws, 1 To 2)
 [i4].CurrentRegion.Offset(1).ClearContents
 For J = 4 To Cells(Rws, "E").End(xlUp).Row
    GTTim = Cells(J, "E").Value
    Set sRng = Rng.Find(GTTim, , xlFormulas, xlPart)
    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        Do
            W = W + 1:                      Arr(W, 1) = GTTim
            Arr(W, 2) = sRng.Value
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
    End If
 Next J
 [i4].Resize(W, 2).Value = Arr()
End Sub

 

[batman1]

Có thể tham khảo thêm 1 giải thuật rùa:

Not sRng Is Nothing And là không cần thiết vì chắc chắn có Not sRng Is Nothing = TRUE.

 

[SA_DQ]

Đúng nhỉ! Lâu nay cứ viết theo lối mòn sách vở!
Xin cảm ơn bạn nhiều!

 

[SA_DQ]

Mình vừa xem lại thì ngày trong Excel 365 cũng vẫn xài như vầy (Dòng lệnh mang số 9):

Sub Hide_Columns()    'Excel objects.    '
 Dim m_wbBook As Workbook, m_wsSheet As Worksheet, m_rnCheck As Range, m_rnFind As Range
 Dim m_stAddress As String    'Initialize the Excel objects.    '
 Set m_wbBook = ThisWorkbook  
 Set m_wsSheet = m_wbBook.Worksheets("Sheet1")        'Search the four columns for any constants.  '
 Set m_rnCheck = m_wsSheet.Range("A1:D1").SpecialCells(xlCellTypeConstants)
  'Retrieve all columns that contain an X.  If there is at least one, begin the DO/WHILE loop.  '
  With m_rnCheck      
     Set m_rnFind = .Find(What:="X") 
     If Not m_rnFind Is Nothing Then
            m_stAddress = m_rnFind.Address
           'Hide the column, and then find the next X.           '
            Do              
               m_rnFind.EntireColumn.Hidden = True 
              Set m_rnFind = .FindNext(m_rnFind) 
9         Loop While Not m_rnFind Is Nothing And m_rnFind.Address <> m_stAddress '  * *   * *   '
       End If
    End With
End Sub

 

[Erebus]

Có thể tham khảo thêm 1 giải thuật rùa:

Sub TimKiemCacChuoiKyTuTrongBang()
 Dim Rws As Long, W As Long, J As Long
 Dim  Rng As Range, sRng As Range
 Dim MyAdd As String, GTTim As String
 
 Set Rng = [B4].CurrentRegion
 Rws = Rng.Rows.Count * [E4].CurrentRegion.Rows.Count
 ReDim Arr(1 To Rws, 1 To 2)
 [i4].CurrentRegion.Offset(1).ClearContents
 For J = 4 To Cells(Rws, "E").End(xlUp).Row
    GTTim = Cells(J, "E").Value
    Set sRng = Rng.Find(GTTim, , xlFormulas, xlPart)
    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        Do
            W = W + 1:                      Arr(W, 1) = GTTim
            Arr(W, 2) = sRng.Value
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
    End If
 Next J
 [i4].Resize(W, 2).Value = Arr()
End Sub

vâng, em cảm ơn bác rất nhiều ạ

 

[batman1]

Mình vừa xem lại thì ngày trong Excel 365 cũng vẫn xài như vầy (Dòng lệnh mang số 9):

Bạn nên đọc help kỹ, không nên nghĩ là các ví dụ tìm được là chuẩn nhất. Các kỹ sư của bác Bill rất giỏi nhưng những ví dụ trong help không phải do những người cực giỏi viết, ít ra thì họ không viết sai nhưng viết thừa là có.

Nên nhớ là nếu trong vùng rng có ít nhất 1 giá trị tìm kiếm (***) thì rng.Find và rng.FindNext luôn trả về kết quả <> NOTHING. Cái đáng chú ý là FINDNEXT khi tìm tới "cuối" vùng rng thì lại quay về "đầu" để tìm tiếp. Do có *** nên đã tìm từ đầu thì chắc chắn sẽ phải lại tìm được. Tóm lại trong trường hợp *** thì giá trị trả về bởi FindNext luôn luôn <> NOTHING. Chính vì lý do này mà không thể ra khỏi DO bằng cách kiểm tra giá trị trả về bởi FindNext. Bắt buộc phải kiểm tra <kết quả>.Address để xem FindNext đã quay lại tìm từ "đầu" hay không.

Trong code của bạn thì phân tích code

If Not sRng Is Nothing Then     ' (A)
    MyAdd = sRng.Address
    Do
        W = W + 1
        Arr(W, 1) = GTTim
        Arr(W, 2) = sRng.Value
        Set sRng = Rng.FindNext(sRng)   ' (B)
    Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If

Nếu ở (A) Not sRng Is Nothing = False thì cụm IF không được thực hiện và code kết thúc. Nếu ở (A) Not sRng Is Nothing = True thì code vào cụm IF. Do có *** nên sau dòng (B) có Not sRng Is Nothing = True. Vì thế vòng Do lại được thực hện và lại do *** nên sau (B) lại có Not sRng Is Nothing = True. Tức nếu tại (A) có Not sRng Is Nothing = True thì sau (B) muôn đời có Not sRng Is Nothing = True. Code của bạn ra được vòng DO chẳng qua do sRng.Address <> MyAdd mà thôi.

Nếu bạn vẫn khôg hiểu phân tích của tôi thì tôi đề nghị chạy code

Sub TimKiemCacChuoiKyTuTrongBang()
 Dim Rws As Long, W As Long, J As Long
 Dim Rng As Range, sRng As Range
 Dim MyAdd As String, GTTim As String

 Set Rng = [B4].CurrentRegion
 Rws = Rng.Rows.Count * [E4].CurrentRegion.Rows.Count
 ReDim Arr(1 To Rws, 1 To 2)
 [i4].CurrentRegion.Offset(1).ClearContents
 For J = 4 To Cells(Rws, "E").End(xlUp).Row
    GTTim = Cells(J, "E").Value
    Set sRng = Rng.Find(GTTim, , xlFormulas, xlPart)
    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        Do
            W = W + 1
'            Arr(W, 1) = GTTim
'            Arr(W, 2) = sRng.Value
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing ' And sRng.Address <> MyAdd
    End If
 Next J
 [i4].Resize(W, 2).Value = Arr()
End Sub

Đó là code của bạn nhưng tôi bỏ 2 dòng trong vòng Do, và bỏ điều kiện And sRng.Address <> MyAdd.

Code trên sẽ chạy tới ngày tận thế. À không, code sẽ chạy tới khi có lỗi Overflow

Ta có kết luận gì? Có lỗi Overflow do vòng lặp Do chạy mãi chạy mãi cho tới khi tràn bộ nhớ do vượt qua giới hạn của kiểu LONG của W. Vòng Do chạy mãi chạy mãi do không ra khỏi được vòng lặp, tức do LUÔN LUÔN có Not sRng Is Nothing = True.

Với cấu trúc

If Not sRng Is Nothing Then
    MyAdd = sRng.Address
    Do
        ...
        Set sRng = Rng.FindNext(sRng)
    Loop While ...
End If

thì FindNext LUÔN LUÔN trả về sRng <> NOTHING.

 

[SA_DQ]

Mình chỉ thắc mắc là sau hàng lô hàng lốc version cho tận đến Excel 365 mà người viết mã chương trình vẫn như cũ, thật lạ(!)
& mình có chút phân vân rằng họ có ẩn ý gì không?

 

[batman1]

Mình chỉ thắc mắc là sau hàng lô hàng lốc version cho tận đến Excel 365 mà người viết mã chương trình vẫn như cũ, thật lạ(!)
& mình có chút phân vân rằng họ có ẩn ý gì không?

Nếu phương thức không thay đổi thì người ta cứ lấy help cũ thôi, lý gì người ta lại phải viết lại?