这个有大神会吗？万分感谢

插入法，原始数据上操作，模拟数据及结果如图：

代码如下：
Sub Test_528()
Dim rng As Range, i&, t&, r&, c&, irow&
Set rng = [a1].CurrentRegion
r = rng.Rows.Count
c = rng.Columns.Count
For i = 1 To c
irow = Cells(Rows.Count, i).End(xlUp).Row
t = r - irow
If t > 0 Then
For j = 1 To t
Cells(1, i).Insert shift:=xlDown
Next
End If
Next
End Sub
缺陷，第一行不能有题头。

方法二：赋值法
模拟数据如图，假设在sheet1:

结果如图，假设在sheet2:

代码如下：
Sub Test_528_1()
Sheet1.Activate
Dim rng As Range, i&, j&, r&, c&, irow&
Set rng = [a1].CurrentRegion
r = rng.Rows.Count
c = rng.Columns.Count
ReDim arr(1 To r, 1 To c)
For j = 1 To c
irow = Cells(Rows.Count, j).End(xlUp).Row
For i = 1 To irow
arr(i + r - irow, j) = rng(i, j)
Next
Next
Sheet2.Activate
[a1].Resize(r, c) = arr
End Sub
如果第一行有标题，请适当修改代码。

方法三：复制法，数据同上
代码如下：
Sub Test_528_2()
Sheet1.Activate
Dim rng As Range, rn As Range
Dim i&, r&, c&, irow&
Set rng = [a1].CurrentRegion
r = rng.Rows.Count
c = rng.Columns.Count
For i = 1 To c
irow = Cells(Rows.Count, i).End(xlUp).Row
Set rn = Range(Cells(1, i), Cells(irow, i))
rn.Copy Sheet2.Cells(r - irow + 1, i)
Application.CutCopyMode = False
Next
Sheet2.Activate
End Sub
同样如果有题头，需要修改代码。这种方法个人不推荐，如果数据量很大，运行效率比较低。

=IFERROR(INDEX(A:A,SMALL(IF(A$1:A$13="",-1,ROW(A$1:A$13)),ROW(A1))),"")

怎么总是吞回帖？=IF(ROW()<=COUNTBLANK(A$1:A$13),"",OFFSET(A1,0-COUNTBLANK(A$1:A$13),))

改了代码，删除了上面发的。思路大同小异，可以解决中间空行的。
Sub s()
ar = Range("a1").CurrentRegion
r = UBound(ar)
c = UBound(ar, 2)
ReDim blk(c - 1)
ReDim br(1 To r, 1 To c)
For i = r To 1 Step -1
For j = 1 To c
If ar(i, j) = "" Then
blk(j - 1) = blk(j - 1) + 1
Else
br(i + blk(j - 1), j) = ar(i, j)
End If
Next j
Next i
Cells(1, 6).Resize(r, c) = br
End Sub