刚发了个求代码的帖子好像被度娘删了，重发一下

链接：https://pan.baidu.com/s/1TuucADcfq5z6csO-9m-X9w?pwd=8888
提取码：8888

Option Explicit
Sub abc()
　Dim a, i, j, p
　a = Sheets("sheet1").UsedRange.Value
　If Not IsArray(a) Then Exit Sub
　For i = UBound(a) To 2 Step -1
　　If Len(a(i, 1)) = 0 Then p = i: Exit For
　Next
　If (p - 2 + 1) Mod 2 Then MsgBox "!": Exit Sub
　If (p - 2 + 1) / 2 <> UBound(a) - p - 2 + 1 Then MsgBox "!!": Exit Sub
　ReDim b((p - 2 + 1) / 2, 1 To UBound(a, 2) * 2)
　For i = 2 To p Step 2
　　For j = 1 To 5
　　　b(i / 2, j) = a(i, j)
　　Next
　Next
　For i = p + 2 To UBound(a)
　　For j = 1 To UBound(a, 2)
　　　b(i - (p + 2) + 1, j + 5) = a(i, j)
　　Next
　Next
　For i = 1 To 3
　　b(0, i + 2) = a(1, i)
　Next
　For i = 1 To UBound(a, 2)
　　b(0, i + 5) = a(p + 1, i)
　Next
　Sheets("sheet2").[a1].Resize(UBound(b) + 1, UBound(b, 2)) = b
End Sub

Option Explicit
Sub abc()
　Dim a, i, j, p
　a = Sheets("sheet1").UsedRange.Value
　If Not IsArray(a) Then Exit Sub
　For i = UBound(a) To 2 Step -1
　　If Len(a(i, 1)) = 0 Then p = i: Exit For
　Next
　If (p - 2 + 1) Mod 2 Then MsgBox "!": Exit Sub
　If (p - 2 + 1) / 2 <> UBound(a) - p - 2 + 1 Then MsgBox "!!": Exit Sub
　ReDim b((p - 2 + 1) / 2, 1 To UBound(a, 2) * 2)
　For i = 2 To p Step 2
　　For j = 1 To 5
　　　b(i / 2, j) = a(i, j)
　　Next
　Next
　For i = p + 2 To UBound(a)
　　For j = 1 To UBound(a, 2)
　　　b(i - (p + 2) + 1, j + 5) = a(i, j)
　　Next
　Next
　For i = 1 To 3
　　b(0, i + 2) = a(1, i)
　Next
　For i = 1 To UBound(a, 2)
　　b(0, i + 5) = a(p + 1, i)
　Next
　With Sheets("sheet2")
　　i = .Cells(Rows.Count, "a").End(xlUp).Row
　　.[a1].Offset(i).Resize(UBound(b) + 1, UBound(b, 2)) = b
　End With
　Sheets("sheet1").Cells.Clear
End Sub