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

level 12

lvcha青青楼主

2023年04月02日 09点04分 1

level 13

阿良

发的神么呀?

2023年04月02日 10点04分 3

lvcha青青

7楼8楼能看到吗

2023年04月02日 10点04分

level 12

lvcha青青楼主

2023年04月02日 10点04分 8

level 13

阿良

Sub test()
With Sheet1
h = .UsedRange.Rows.Count 'sheet1的行数
.Range("a2:K" & h).Copy Sheet2.Range("A" & Sheet2.UsedRange.Rows.Count + 1)
.Range("a2:K" & h).ClearContents
End With
End Sub

2023年04月02日 10点04分 9

lvcha青青

代码有效，只是最后清除表1数据的时候，没有清除表1的标题行以及其他数据区域留下来的格式。

2023年04月02日 10点04分

lvcha青青

还有一点就是复制过去的时候，把表2最后一行数据覆盖了。

2023年04月02日 10点04分

lvcha青青

自个瞎改了一下，现在能清除表1的带标题行的数据以及格式。至于刚才说的把表2最后一行覆盖，好像也不存在了。谢谢靓仔。

2023年04月02日 10点04分

level 13

阿良

Sub test()
With Sheet1
h = .UsedRange.Rows.Count 'sheet1的行数
h1 = IIf(Sheet2.UsedRange.Rows.Count = 1, 0, Sheet2.UsedRange.Rows.Count) + 1
.Range("a1:K" & h).Copy Sheet2.Range("A" & h1)
.UsedRange.ClearContents
End With
End Sub

2023年04月02日 10点04分 10

阿良

.clearcontents删除文本的意思. 什么都不想要了是.clear

2023年04月02日 11点04分

lvcha青青

@阿良

2023年04月02日 11点04分

lvcha青青

能不能帮忙看看楼下的链接中文件，比前面多了一个限定条件，就是数据的行数不固定的情况下怎么修改代码。

2023年04月03日 07点04分

level 12

lvcha青青楼主

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

2023年04月03日 07点04分 11

阿良

我还在石器时代加v发我 xyc78195184

2023年04月03日 07点04分

level 11

🌴菠萝蜜🌴

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

2023年04月03日 07点04分 12

lvcha青青

首先感谢大神。有3个小问题：1，复制到表2以后并没有清除表1数据。2，运行了一次宏后，再运行宏时好像不起作用了。3、数据行增加以后，不能正常运行，出现两个叹号的提示框。

2023年04月03日 08点04分

lvcha青青

上面说的第2个问题应该是在粘贴到表2时，没有考虑表2原来会有数据，假如表2原来有数据，就直接覆盖表2的数据了，没有从最下面粘贴。

2023年04月03日 08点04分

level 11

🌴菠萝蜜🌴

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

2023年04月03日 10点04分 13

🌴菠萝蜜🌴

凑了一个，看上去应该差不多的吧。

2023年04月03日 10点04分

lvcha青青

@🌴菠萝蜜🌴 完美，谢谢大神。

2023年04月03日 11点04分