Sub gopdulieu()
Dim arr, i As Long, s As String, kq, dic As Object, ngay As String, b As Long, T, k As Integer, s1 As String, s2 As String
Dim a As Long, ten As String, j As Integer
Set dic = CreateObject("scripting.dictionary")
With Sheets("Sheet1")
arr = .Range("B5:C58").Value
ReDim kq(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr)
ngay = arr(i, 2)
If Not dic.exists(ngay) Then
dic.Add ngay, "#" & arr(i, 1)
a = a + 1
kq(a, 1) = ngay
Else
s = dic.Item(ngay)
s = s & "#" & arr(i, 1)
dic.Item(ngay) = s
End If
Next i
For i = 1 To a
s = dic.Item(kq(i, 1))
T = Split(s, "#")
b = UBound(T)
For k = 1 To b
s1 = T(k)
If InStr(1, s, s1) Then
ten = ten & ";" & s1
j = 0
Do
j = j + 1
s2 = Left(s1, Len(s1) - 4) & (Right(s1, 4) + j)
If InStr(1, s, s2) Then
s = Replace(s, s2, "")
Else
s2 = Left(s1, Len(s1) - 4) & (Right(s1, 4) + j - 1)
If s1 <> s2 Then ten = ten & "-" & s2
Exit Do
End If
Loop
End If
Next k
kq(i, 2) = Right(ten, Len(ten) - 1)
ten = Empty
Next i
.Range("F14:G14").Resize(a).Value = kq
End With
End Sub