Sub GPE()
Dim I As Long, J As Long, K As Long, C As Long, Col As Long, lR As Long
Dim Rng As Range, Dat As Date
Dim Arr, sArr(), Res()
With Sheet1
Set Rng = .Range("B2", .Range("B2").End(xlDown))
Col = .Cells(3, Columns.Count).End(xlToLeft).Column - 1
ReDim Res(1 To Rng.Rows.Count * Col, 1 To 4)
Arr = FindArray(Rng, "Ngày", True)
For I = LBound(Arr) To UBound(Arr)
Dat = CDate(.Range(Arr(I)).Offset(, 1))
lR = .Range(Arr(I)).Offset(1, 2).End(xlDown).Row
sArr() = .Range(.Range(Arr(I)).Offset(1), .Range("B" & lR)).Resize(, Col).Value
For J = 2 To UBound(sArr, 1)
For C = 2 To UBound(sArr, 2)
If sArr(J, C) Then
K = K + 1
Res(K, 1) = sArr(1, C): Res(K, 2) = Dat
Res(K, 3) = sArr(J, 1): Res(K, 4) = sArr(J, C)
End If
Next C
Next J
Next I
End With
If K Then
Sheet3.Range("B2").Resize(K, 4) = Res
End If
End Sub
Function FindArray(FindArea As Range, SearchStr As String, Optional Arrange As Boolean = True)
Dim ArrayList As Object
Dim MyResults() As String
Dim n As Long, I As Long
Dim aCell As Range, bCell As Range, ExitLoop
Set aCell = FindArea.Find(What:=SearchStr, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
ReDim Preserve MyResults(n + 1)
MyResults(n) = aCell.Address
n = n + 1
Do While ExitLoop = False
Set aCell = FindArea.FindNext(after:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
ReDim Preserve MyResults(n)
MyResults(n) = aCell.Address
n = n + 1
Else
ExitLoop = True
End If
Loop
Else
Exit Function
End If
Set ArrayList = CreateObject("System.Collections.Arraylist")
If Arrange Then
For I = LBound(MyResults) To UBound(MyResults)
ArrayList.Add MyResults(I)
Next I
ArrayList.Sort
FindArray = ArrayList.ToArray
Set ArrayList = Nothing
Else
FindArray = MyResults
End If
Set aCell = Nothing: Set bCell = Nothing
End Function
