dùng advance filter nhé
Dữ liệu mình bố trí như vậy, dùng code được không bạn
bạn giúp mình code đi nhé.
Code cho sheet LOC
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [I5:I6]) Is Nothing Then
[A7:I1000].ClearContents
Loc
End If
End SubSub Loc()
Dim Sarr(), Res(1 To 10000, 1 To 9)
Dim Str1 As String, Str2 As String, Found1 As Range, Found2 As Range
Dim Col As Long, I As Long, J As Long, K As Long
Str1 = Sheets("Loc").[I5]: Str2 = Sheets("Loc").[I6]
With Sheets("Data")
Set Found1 = .[I5:AJ5].Find(Str1, , , 1)
If Not Found1 Is Nothing Then
Set Found2 = Found1.Offset(1).Resize(, 6).Find(Str2, , , 1)
If Not Found2 Is Nothing Then
Sarr = .Range(.[B7], .[B65536].End(3)).Resize(, Found2.Column - 1).Value
For I = 1 To UBound(Sarr)
If UCase(Sarr(I, UBound(Sarr, 2))) = "X" Then
K = K + 1
For J = 1 To 7
Res(K, J + 1) = Sarr(I, J)
Next
Res(K, 1) = K: Res(K, 9) = "X"
End If
Next
If K Then Sheets("loc").[A7].Resize(K, 9) = Res
End If
End If
End With
End SubVD: Mình muốn thêm vùng [I5:AJ5] thành vùng [I5:CU5] chẳng hạn mình có chỉnh sửa thêm code gì nữa không bạn Hải hay chỉ thêm vùng đó vào là ổn.
+
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [I5:I6]) Is Nothing Then
[A7:I1000].Clear
Loc
End If
End SubSub Loc()
Dim Sarr(), Res(1 To 10000, 1 To 9)
Dim Str1 As String, Str2 As String, Found1 As Range, Found2 As Range
Dim I As Long, J As Long, K As Long, C As Long
Str1 = Sheets("Loc").[I5]: Str2 = Sheets("Loc").[I6]
With Sheets("Data")
Set Found1 = .[I5:AJ5].Find(Str1, , , 1)
If Not Found1 Is Nothing Then
C = Found1.End(2).Column - Found1.Column
Set Found2 = Found1.Offset(1).Resize(, C).Find(Str2, , , 1)
If Not Found2 Is Nothing Then
Sarr = .Range(.[B7], .[B65536].End(3)).Resize(, Found2.Column - 1).Value
For I = 1 To UBound(Sarr)
If UCase(Sarr(I, UBound(Sarr, 2))) = "X" Then
K = K + 1
For J = 1 To 7
Res(K, J + 1) = Sarr(I, J)
Next
Res(K, 1) = K: Res(K, 9) = "X"
End If
Next
If K Then
Sheets("loc").[A7].Resize(K, 9) = Res
Sheets("loc").[A7].CurrentRegion.Borders.Value = 1
End If
End If
End If
End With
End Subhỏng khó đâu anh hải. Chỉ cần 1 chút thủ thuật là ngon lành cành đào mà
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.ScreenUpdating = False
If Not Intersect(Target, [E3:E4]) Is Nothing Then
Sheet2.[A7:AJ65000].Clear
Sheet1.[B7:AJ6500].AdvancedFilter 2, [f3:f4], [B6:I6], False
Sheet2.Range("B6:B" & [B55000].End(3).Row).Offset(0, -1).Value = Evaluate("ROW(R:R)-1")
[A6] = "STT"
[A6].CurrentRegion.Borders.Value = 1
End If
Application.ScreenUpdating = True
End Sub
