Anh có thể giúp em đoạn code này được không ạ !
Em cảm ơn chị Ạ. ! chị có thể giúp em Bằng đoạn VBA được không ạ !
Bạn xem nhé.Xem có đúng ý không.
Sub tach()
Dim arr, arr1
Dim a As Long, lr As Long, i As Integer, j As Integer
Dim dk1, dk2 As String
With Sheets("Data")
lr = .Range("A" & Rows.Count).End(xlUp).Row
If lr < 2 Then Exit Sub
arr = .Range("A2:I" & lr).Value
ReDim arr1(1 To UBound(arr, 1), 1 To 9)
End With
With Sheets("trichloc")
dk1 = "*" & .Range("A2").Value & "*"
dk2 = "*" & .Range("b2").Value & "*"
For i = 1 To UBound(arr, 1)
If UCase(arr(i, 7)) Like UCase(dk1) And UCase(arr(i, 8)) Like UCase(dk2) Then
a = a + 1
For j = 1 To 9
arr1(a, j) = arr(i, j)
Next j
End If
Next i
lr = .Range("C" & Rows.Count).End(xlUp).Row
If lr > 3 Then .Range("C4:K" & lr).ClearContents
If a Then .Range("C4").Resize(a, 9).Value = arr1
End With
End SubDạ của em nó là 1 mảng có nhiều lấy nhiều cặp A2-B2 xuống dưới nữa chứ không phải như vậy anh ạ !. Cái này mới giải quyết được A2 và B2 thay đổi thôi ạ
Bạn dùng thử code này xem.
Dim a As Long, lr As Long, i As Integer, j As Integer
Dim dk As Long
With Sheets("Data")
lr = .Range("A" & Rows.Count).End(xlUp).Row
If lr < 2 Then Exit Sub
arr = .Range("A2:I" & lr).Value
ReDim arr1(1 To UBound(arr, 1), 1 To 9)
End With
With Sheets("trichloc")
lr = .Range("A" & Rows.Count).End(xlUp).Row
If lr < 2 Then Exit Sub
arr2 = .Range("A2:B" & lr).Value
For i = 1 To UBound(arr, 1)
dk = kiemtra(arr2, arr(i, 7), arr(i, 8))
If dk = 1 Then
a = a + 1
For j = 1 To 9
arr1(a, j) = arr(i, j)
Next j
End If
Next i
lr = .Range("C" & Rows.Count).End(xlUp).Row
If lr > 3 Then .Range("C4:K" & lr).ClearContents
If a Then .Range("C4").Resize(a, 9).Value = arr1
End With
End Sub
Function kiemtra(ByVal arr As Variant, ByVal dk1 As String, ByVal dk2 As String) As Long
Dim a As Long, i As Long
Dim dk As String
For i = 1 To UBound(arr, 1)
If UCase(dk1) Like UCase("*" & arr(i, 1) & "*") And UCase(dk2) Like UCase("*" & arr(i, 2) & "*") Then
kiemtra = 1
Exit For
End If
Next i
End FunctionDạ vâng em cảm ơn anh Ạ !
