Sub LietKe()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim MyRng As Range, MyCll As Range, FindCll As Range, FirstAdd As String, OldData, NewData(), i As Long
Set MyRng = Range([C1], [A65536].End(xlUp).Offset(1, 2))
MyRng.Offset(, 4).Resize(, 250).ClearContents
Set FindCll = [C1]
Set MyCll = MyRng.Find("", FindCll, , xlWhole, , xlNext)
Set FindCll = MyCll
FirstAdd = FindCll.Address
Do Until MyRng.FindNext(FindCll).Address = FirstAdd
Set MyCll = MyRng.FindNext(FindCll)
If MyCll.Row - 1 > FindCll Then
OldData = Range(FindCll.Offset(1), MyCll.Offset(-1, 1)).Value
ReDim NewData(1 To 1, 1 To UBound(OldData, 1) * 2)
For i = 1 To UBound(OldData, 1)
NewData(1, (i - 1) * 2 + 1) = OldData(i, 1)
NewData(1, i * 2) = OldData(i, 2)
Next
FindCll.Offset(, 4).Resize(, UBound(OldData, 1) * 2).Value = NewData
End If
Set FindCll = MyCll
Loop
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub