格式转换,排列,高手请进

elongn

Sub copyText()
Dim i%, k%, s%
Dim Str1 As String, Str2 As String, Str3 As String, Str4 As String
Dim hehao As Integer

k = [A65536].End(xlUp).Row + 1
i = 1
Str1 = "红河流域"
Str2 = "年份"
Str3 = "单沙"

While Not i = k
    If Not Range("d" & i) = Range("d" & i + 1) Then
        'Rows (i + 1 & ":" & i + 1).Insert Shift:=xlDown
        Range("e" & i + 1) = Range("e" & i)
        k = k + 1
        i = i + 1
        Cells(i, 5) = Str1
        Cells(i, 6) = Range("b" & i) & Str2
        Cells(i, 7) = Str3
        Cells(i, 8) = Range("d" & i)
        
       Cells(i + 1, 5) = Cells(i, 3)
    Else
        i = i + 1
        'Rows(i + 1 & ":" & i + 1).Insert Shift:=xlDown
    End If
Wend
End Sub
得到的结果是红河流域        1950年份        单沙        1
董户村                       
                       
                       
                       
                       
                       
                       
红河流域        1963年份        单沙        2
元江（二）                       
                       
                       
想要得到的结果
红河流域        1963-1965年        单沙        2
元江（二）        大东勇        元江（二）        蛮耗（二、尾水）
南溪街        忠爱桥        元江（二）        蛮耗（二、尾水）
忠爱桥                       
                       
红河流域        1966年        单沙        3
大东勇        元江（二）        蛮耗（二、尾水）        南溪街
忠爱桥        龙潭寨        天保        水沟
                       
                       
                       
                       
                       
红河流域        1966年份        单沙        3
大东勇