Option Explicit
Sub TongHop(ByVal NS As Range)
Dim i&, j&, Lr&, t&, k&, d&, Cot&, R&, C&, C1&, dong&, Col&
Dim Ws As Worksheet, Sh As Worksheet, Rng As Range, f As Range
Dim Arr(), KQ()
Dim Dic As Object, key
Dim Nam As Long, H&
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
On Error GoTo Loi
Set Dic = CreateObject("Scripting.Dictionary")
Set Sh = Sheets("TONG")
Set Rng = Sh.Range("A1:A50")
Set f = Rng.Find(What:="STT", LookAt:=xlWhole, LookIn:=xlValues)
If Not f Is Nothing Then
d = f.Row
C1 = Sh.Cells(d, 1).End(xlToRight).Column
End If
For j = 1 To C1
If Sh.Cells(d, j).Value <> Empty Then
key = Trim(Sh.Cells(d, j).Value)
Dic.Add (key), j: Dic(key) = j
End If
Next j
ReDim KQ(1 To 5000, 1 To C1)
For Each Ws In Worksheets
If Ws.Name <> "TONG" Then
Set Rng = Ws.Range("A4:F8")
Set f = Rng.Find(What:="STT", LookAt:=xlWhole, LookIn:=xlValues)
If Not f Is Nothing Then
dong = f.Row
Col = Ws.Cells(dong, Columns.Count).End(xlToLeft).Column
Set Rng = Ws.Range("A" & dong & ":P" & dong)
Set f = Rng.Find(What:="Ngày", LookAt:=xlPart, LookIn:=xlValues)
If Not f Is Nothing Then
Cot = f.Column
Lr = Ws.Cells(Ws.Rows.Count, Cot).End(xlUp).Row
If Lr > dong Then
Arr = Ws.Range(Ws.Cells(dong, 1), Ws.Cells(Lr, Col)).Value ''"A" & dong & ":Q" & Lr).Value
R = UBound(Arr)
C = UBound(Arr, 2)
For i = 3 To R
H = 0
If Arr(i, Cot) <> Empty Then
If IsDate(Arr(i, Cot)) Then
Nam = Year(Arr(i, Cot))
ElseIf IsNumeric(Arr(i, Cot)) And Len(Arr(i, Cot)) = 4 Then
Arr(i, Cot) = Nam = Arr(i, Cot): Arr(i, Cot) = DateSerial(Nam, 1, 1) ' Thay (Nam,1,1) thành (Nam,số <0 Tùy ý<=12, Số <0<=31)
End If
If Nam = NS Or NS Like "T?t c?" Then
t = t + 1
KQ(t, 1) = t
For j = 2 To C
k = Dic(Trim(Arr(1, j)))
If k Then KQ(t, k) = Arr(i, j)
Next j
End If
End If
Next i
End If
End If
End If
End If
Next Ws
If t > 0 Then
Sh.Range("A8").Resize(10000, C1).ClearContents
Sh.Range("A8").Resize(t, C1).Value = KQ
End If
Thoat:
With Application
.CutCopyMode = False
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
Loi:
MsgBox "Có lôi: " & Err.Number & vbCrLf & _
Err.Description, vbCritical, "THÔNG BÁO"
GoTo Thoat
End Sub
