Xin trợ giúp về tìm kiếm và thay thế

[buihuuchung]

Chào mọi người, em có vấn đề xin nhờ mọi người trợ giúp về code VBA
Em có 1 bảng dữ liệu tại sheet1(file đính kèm) và 1 bảng dữ liệu tại sheet2 (file đính kèm)
-Tại bảng dữ liệu sheet1, em muốn tìm xe các mã tại cột B, có đc tách thành các thành phần nhỏ hơn không (tìm tại bảng dữ liệu thành phần trong sheet2)
- Nếu có mã cần tách thì thực hiện tách mã đó thành các thành phần như trong bảng dữ liệu sheet2
- Ghi chèn vào bảng dữ liệu hiện tại của sheet1

 

[bebo021999]

Dùng thử cái này nhé:

Option Explicit
Sub tach()
Dim i&, j&, k&, rng, rng2, res(1 To 100000, 1 To 3), ma As Range
With Sheets("Sheet2")
    Set ma = .Range("C2:E" & .Cells(Rows.Count, "C").End(xlUp).Row)
    rng2 = ma.Value
End With
With Sheets("Sheet1")
    rng = .Range("A3:C" & .Cells(Rows.Count, "B").End(xlUp).Row).Value
    For i = 1 To UBound(rng)
        If WorksheetFunction.CountIf(ma.Columns(1), rng(i, 2)) = 0 Then
            k = k + 1: res(k, 1) = k: res(k, 2) = rng(i, 2): res(k, 3) = rng(i, 3)
        Else
            For j = 1 To UBound(rng2)
                If rng(i, 2) = rng2(j, 1) Then
                    k = k + 1: res(k, 1) = k: res(k, 2) = rng2(j, 2): res(k, 3) = rng2(j, 3)
                End If
            Next
        End If
    Next
    .Range("A3:C10000").ClearContents
    .Range("A3").Resize(k, 3).Value = res
End With
End Sub

 

[buihuuchung]

Cảm ơn bebo021999
Code chạy đúng ý mình luôn
Cảm ơn bạn rất nhiều

 

[SA_DQ]

Bạn tham khảo thêm cách rùa này:

Sub TimVaThayThe()
 Dim Rng As Range, sRng As Range, Cls As Range
 Dim MyAdd As String
 Dim Rws As Long, W As Integer, Dg As Long
 
 Sheet1.Select
 Dg = [B3].CurrentRegion.Rows.Count
 With Sheet2
    Rws = .[C2].CurrentRegion.Rows.Count
    Set Rng = .[D1].Resize(Rws)
    ReDim Arr(1 To Dg * Rws, 1 To 3)
    [F3].Resize(Rws * Dg, 3).Value = ""
    For Each Cls In Range([B3], [B3].End(xlDown))
        Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlPart)
        If sRng Is Nothing Then
            W = W + 1:              Arr(W, 1) = W
            Arr(W, 2) = Cls.Value:  Arr(W, 3) = Cls.Offset(, 1).Value
        Else
            MyAdd = sRng.Address
            Do
                W = W + 1:              Arr(W, 1) = W
                Arr(W, 2) = sRng.Value: Arr(W, 3) = sRng.Offset(, 1).Value
                Set sRng = Rng.FindNext(sRng)
            Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
        End If
    Next Cls
 End With
 If W Then [F3].Resize(W, 3).Value = Arr()
End Sub

 

[buihuuchung]

Thanks bạn SA_DQ nhiều nhé