Sub Tonghopdulieu()
Dim Stt(), Res()
Dim Ws As Worksheet, fRange As Range, fRangeNext As Range
Dim I As Byte, fRow As Integer, fRowNext As Integer, K As Integer, lR As Integer, lR1 As Integer, lR2 As Integer
Dim IsFirstWorksheet As Boolean
Application.ScreenUpdating = False
'Xoa du lieu cu
Sheet4.Range("A1").CurrentRegion.Offset(1).ClearContents
'Tao mang chua cac So thu tu can tong hop
lR = Sheet4.Range("P" & Rows.Count).End(xlUp).Row
If lR = 1 Then
MsgBox "Chua co thong tin STT can tong hop", vbCritical, "GPE"
Exit Sub
Else
Stt() = Sheet4.Range("P2").Resize(lR - 2 + 1).Value
End If
'Quy dinh kich thuoc mang ket qua
'ReDim Res(1 To 100, 1 To 12)
'Vong lap qua tung phan tu cua mang Stt
For I = 1 To UBound(Stt, 1)
'Sheet kiem tra dau tien
IsFirstWorksheet = True
'Vong lap qua tung sheet trong workbook
For Each Ws In ThisWorkbook.Sheets
With Ws
'Neu khong dung Sheets("KET QUA") thi tiep tuc, dung thi chuyen sheet tiep theo
If .Name <> "KET QUA" Then
'Tim trong cot A o co chua So thu tu can tong hop
Set fRange = .Range("A:A").Find(Stt(I, 1))
'Neu fRang co ket qua
If Not fRange Is Nothing Then
'Chi so dong cua fRange
fRow = fRange.Row
'Tim dong tiep theo co du lieu trong cot A sau fRow
fRowNext = .Range("A:A").Find(what:="?*", After:=fRange, LookIn:=xlValues).Row
'Truong hop fRow la dong cuoi cung co du lieu trong cot A, fRowNext tra ve ket qua <= fRow
If fRowNext <= fRow Then
'Gan fRowNext theo chi so dong cuoi o cot B
fRowNext = .Range("B" & Rows.Count).End(xlUp).Row + 1
End If
'Dong cuoi cung co du lieu trong Sheets("KET QUA") + 1 --> dong dau tien de dien ket qua
lR1 = Sheet4.Range("I" & Rows.Count).End(xlUp).Row + 1
lR2 = Sheet4.Range("J" & Rows.Count).End(xlUp).Row + 1
If lR1 > lR2 Then lR = lR1 Else lR = lR2
'Neu la Sheet dau tien
If IsFirstWorksheet Then
K = fRowNext - fRow
'Gan gia tri can tim vao mang Ket qua
Res() = .Range("A" & fRow).Resize(K, 12).Value
'Chuyen gia tri cho bien
IsFirstWorksheet = False
Else
K = fRowNext - fRow - 1
'Gan gia tri can tim vao mang Ket qua
If K Then
Res() = .Range("A" & (fRow + 1)).Resize(K, 12).Value
Else
Res() = .Range("A" & fRow).Resize(, 12).Value
Res(1, 1) = ""
End If
End If
'Dien ket qua vao Sheets("KET QUA")
Sheet4.Range("A" & lR).Resize(UBound(Res, 1), 12) = Res
'Xoa toan bo du lieu trong mang ket qua
Erase Res
End If
End If
End With
Next Ws
Next I
Application.ScreenUpdating = True
MsgBox "Done", vbInformation, "GPE"
End Sub
