Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Loi_WC
If Not Intersect(Target, [B2]) Is Nothing Then
Dim Sh As Worksheet
Dim Rng As Range, sRng As Range, cRng As Range
Dim MyAdd As String
Dim Col As Byte
Dim Rw As Long, sRw As Long
Set Sh = Sheets("TKB chung")
Set Rng = Union(Sh.Range("c5:s34"), Sh.Range("c40:o43"), Sh.Range("c45:o69"))
Set sRng = Rng.Find(Target.Value, , xlFormulas, xlPart)
If Not sRng Is Nothing Then
MyAdd = sRng.Address: Union(Range("C5:M9"), Range("B6:B9")).ClearContents
Do
sRw = sRng.Row
Rw = 4 + Sh.Cells(sRw, "B")
If sRng.Row < 35 Then
Col = Switch(sRw < 10, 2, sRw < 15, 4, sRw < 19, 6, sRw < 24, 8, sRw < 29, 10, sRw < 35, 12)
Cells(Rw, Col).Value = Sh.Cells(4, sRng.Column)
Else
Col = Switch(sRw < 45, 3, sRw < 50, 5, sRw < 55, 7, sRw < 60, 9, sRw < 65, 11, sRw < 70, 13)
Cells(Rw, Col).Value = Sh.Cells(39, sRng.Column)
End If
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
End If
Err_WC: Exit Sub
Loi_WC:
MsgBox sRng.Address: Resume Err_WC
End SubOption Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Loi_WC
If Not Intersect(Target, [B2]) Is Nothing Then
Dim Sh As Worksheet: Dim sRw As Long, Rw As Long
Dim Rng As Range, sRng As Range, cRng As Range
Dim MyAdd As String: Dim Col As Byte
Set Sh = Sheets("TKB chung")
Set Rng = Union(Sh.Range("c5:s34"), Sh.Range("c40:o43"), Sh.Range("c45:o69"))
Set sRng = Rng.Find(Target.Value, , xlFormulas, xlPart)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Union(Range("C5:M9"), Range("B6:B9")).ClearContents
Do
sRw = sRng.Row: Rw = 4 + Sh.Cells(sRw, "B")
If sRw < 35 Then
15 Col = Switch(sRw < 10, 2, sRw < 15, 4, sRw < 20, 6, sRw < 25, 8, _
sRw < 30, 10, sRw < 35, 12)
Else
Col = Switch(sRw < 45, 3, sRw < 50, 5, sRw < 55, 7, sRw < 60, 9, _
sRw < 65, 11, sRw < 70, 13)
End If
Cells(Rw, Col).Value = Sh.Cells(IIf(sRw < 35, 4, 39), sRng.Column)
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
End If
Err_WC: Exit Sub
Loi_WC:
MsgBox sRng.Address: Resume Err_WC
End SubMacro lấy tên lớp ở dòng 4 & 39; Đương nhiên trong dòng này không chứa ký tự phụ rồi!
À do không đọc được, nên mình đã xóa mất tiêu từ đầu rồi!
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Loi_WC
If Not Intersect(Target, [B2]) Is Nothing Then
Dim Sh As Worksheet: Dim sRw As Long, Rw As Long
Dim Rng As Range, sRng As Range, cRng As Range
Dim MyAdd As String: Dim Col As Byte
Set Sh = Sheets("TKB chung")
Set Rng = Union(Sh.Range("c5:s34"), Sh.Range("c40:o43"), Sh.Range("c45:o69"))
Set sRng = Rng.Find(Target.Value, , xlFormulas, xlPart)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Union(Range("C5:M9"), Range("B6:B9")).ClearContents
Do
sRw = sRng.Row: Rw = 4 + Sh.Cells(sRw, "B")
Col = Switch(sRw < 10, 2, sRw < 15, 4, sRw < 20, 6, sRw < 25, 8, _
sRw < 30, 10, sRw < 35, 12, sRw < 45, 3, sRw < 50, 5, sRw < 55, _
7, sRw < 60, 9, sRw < 65, 11, sRw < 70, 13)
Cells(Rw, Col).Value = Sh.Cells(IIf(sRw < 35, 4, 39), sRng.Column) & _
IIf(Len(sRng.Value) = 4, "(" & Right(sRng.Value, 1) & ")", "")
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
End If
Err_WC: Exit Sub
Loi_WC:
MsgBox sRng.Address: Resume Err_WC
End Sub
Vấn đề ở đây không chỉ là ứng dụng mà là học hỏi.
Có thể có một chương trình nào khác hay hơn, hữu dụng hơn nhưng khi gặp một vấn đề khác bạn có thể tự giải quyết không?? Ngược lại, những người thích nghiên cứu, ham học hỏi có lẽ sẽ tìm ra được giải pháp đấy.
