Function doingay(ByVal ngay As String, ByVal dk As String, Optional phancach As String = ":")
Dim VB As Object
Set VB = CreateObject("VBScript.regexp")
VB.Global = True
VB.Pattern = "\" & dk
doingay = VB.Replace(ngay, phancach)
End Function
Sub chuyendoi(ByVal arr, ByVal dk As String, ByVal ten As String)
Dim arr1, arr2, i As Long, j As Long, lr As Long, so As Double, a As Long, mon As String, slist As Object, k As Long, olit As Object
Set slist = CreateObject("System.Collections.ArrayList")
ReDim arr1(1 To UBound(arr, 1), 1 To 9)
For i = 1 To UBound(arr, 1)
If Len(arr(i, 3)) = 0 Then
If Len(arr(i + 1, 3)) = 0 Then
a = a + 1
mon = arr(i, 1)
arr1(a, 1) = mon
arr1(a, 2) = arr(i + 1, 1)
i = i + 1
Else
a = a + 1
arr1(a, 1) = mon
arr1(a, 2) = arr(i, 1)
End If
Else
If UCase(arr(i, 1)) = dk Then
arr1(a, 3) = dk
For j = 5 To 8
arr1(a, j) = arr(i, j - 2)
Next j
so = CDate(doingay(arr(i, 4), "h", ":"))
arr1(a, 9) = CLng(CDate(doingay(arr(i, 3), ".", "-"))) + so
slist.Add arr1(a, 9) & arr1(a, 2)
End If
End If
Next i
Set olit = slist.Clone
slist.Sort
k = slist.Count
ReDim arr2(1 To a, 1 To 8)
For i = 0 To k - 1
a = olit.InDexOf(slist(i), 0) + 1
For j = 1 To 8
arr2(i + 1, j) = arr1(a, j)
Next j
Next i
With Sheets(ten)
lr = .Range("A" & Rows.Count).End(xlUp).Row
If lr > 3 Then .Range("A3:H" & lr).ClearContents
.Range("a3").Resize(k, 8).Value = arr2
End With
End Sub
Sub tachlan1()
Dim lr As Long, arr, arr2
With Sheets("du lieu")
lr = .Range("C" & Rows.Count).End(xlUp).Row
If lr < 5 Then Exit Sub
arr = .Range("A3:F" & lr).Value
End With
chuyendoi arr, "THI L" & ChrW(7846) & "N 1", "lan 1"
End Sub
Sub tachlan2()
Dim lr As Long, arr, arr2
With Sheets("du lieu")
lr = .Range("C" & Rows.Count).End(xlUp).Row
If lr < 5 Then Exit Sub
arr = .Range("A3:F" & lr).Value
End With
chuyendoi arr, "THI L" & ChrW(7846) & "N 2", "lan 2"
End Sub