ExceL不规则行数批量转置

Question

像这样有6行、7行、4行等行数不固定，怎么批量转置，新手，钱不多

Answer 1

建议用公式。sheet1是源数据，sheet2的A1写：
“=INDIRECT("Sheet1!"&CHAR(ROW(A65))&COLUMN())”，下拉填充，横向拉填充即可。通过公式达到行列转置的效果，跟源数据区域大小无关。“CHAR(ROW(A65))”是字母A，下拉后依次是B，C，D一直到Z，生成列号，“COLUMN()”是当前列号，用于生成行号。
或者写：“=INDIRECT("sheet1!"&"R"&COLUMN()&"C"&ROW(),0)”，这个公式可以突破源数据不能大于26列的限制。追问

这个公式弄出来的是只有一行数据

追答

向右拉就是其它的，这个公式既能下拉也能右拉的。

Answer 2

Sub a()
    Dim iRow As Long, i As Long, lastRow As Long
    Dim str As String, arr As Variant
    Application.ScreenUpdating = False
    iRow = Range("A60000").End(xlUp).Row
    lastRow = Range("B60000").End(xlUp).Row + 1
    For i = 2 To iRow
        If InStr(Cells(i, 1), "公司") > 0 Then
            str = str & i & ","
        End If
    Next
    arr = Split(Left(str, Len(str) - 1), ",")
    For i = 0 To UBound(arr)
        If i < UBound(arr) Then
            Range("A" & arr(i), "A" & arr(i + 1) - 1).Copy
            Range("B" & lastRow).PasteSpecial Transpose:=True
            lastRow = Range("B60000").End(xlUp).Row + 1
        Else
            Range("A" & arr(i), "A" & iRow).Copy
            Range("B" & lastRow).PasteSpecial Transpose:=True
        End If
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

应该有更简便的循环方式，暂时先用上面这个吧。

Answer 3

假设原始数据在A2：A1000中，每段打头的都有“中国电信电白分公司”字样，B2中输入
=IFERROR(PHONETIC(OFFSET(A$1,SMALL(IF(A$2:A$1000="中国电信电白分公司",ROW($2:$1000)),ROW(A1))-1,,IFERROR(SUM(SMALL(IF(A$2:A$1000="中国电信电白分公司",ROW($2:$1000)),ROW(1:2))*{-1;1}),9))),"")
同时按下CTRL+SHIFT+回车，输入数组公式，下拉。如果单元格地址不对，自己适当调整。追问

不好意思，输入公式后第一行是空白，第2行及以下都是0，哪里不对呢？

Answer 4

选中包含所有数据的长方体，复制，在空白的地方用“转置黏贴”追问

你这是单个转置，一转置就变成一行数据了，是每隔中国电信电白分公司转置一次