Excel VBA转置每个空单元格的连续范围

我有一个excel文件，连续的单元格以空行分隔 前任： 名称 阿迪斯 电话 传真 网状物 --空行-- 名称 地址1 地址2 电话 网状物 --空行--

我需要获取每个连续范围，并将其转置到每个范围右侧的列中 实际上，我需要手动选择范围，然后运行一个快捷宏，以使用以下代码进行转换：

ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

---

您能帮我在vba中选择第一个范围并将其转置，然后在空行后选择下一个范围并将其转置，然后再转置，直到文件结束吗？

这是怎么回事？我假设您的数据如下所示（A列和B列）

使用此宏将导致数据被转置，从C列开始：

  Sub test()
    Dim lastRangeRow As Integer, lastRow As Integer, i As Integer, copyCol As Integer
    Dim noOfReports As Integer

    copyCol = 2 'Column "B" has the info you want to transpose.  Change if different
    lastRow = Sheets("Sheet1").UsedRange.Rows.Count

    '  How many blank cells are there? This will tell us how many times to run the macro
    noOfReports = Range(Cells(1, 1), Cells(lastRow, 1)).SpecialCells(xlCellTypeBlanks).Cells.Count + 1

i = 1
Do While i <= lastRow 'until you reach the last row, transpose the data
    With Sheets("Sheet1")
        lastRangeRow = .Cells(i, copyCol).End(xlDown).Row
        .Range(.Cells(i, copyCol), .Cells(lastRangeRow, 2)).Copy
        .Cells(i, copyCol + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

        If lastRangeRow >= lastRow Then
            Exit Do
        Else
            i = .Cells(i, copyCol).End(xlDown).End(xlDown).Row
        End If
    End With
Loop

MsgBox ("Done!")
Application.CutCopyMode = False

End Sub

子测试（）
Dim lastRangeRow为整数，lastRow为整数，i为整数，copyCol为整数
Dim noOfReports为整数
copyCol=2'列“B”中有要转置的信息。如果不同，请更改
lastRow=图纸（“图纸1”）。使用drange.Rows.Count
“有多少个空白单元格？这将告诉我们运行宏的次数
noOfReports=范围（单元格（1，1），单元格（lastRow，1））。特殊单元格（xlCellTypeBlanks）。Cells.Count+1
i=1
当我向奥利弗问好的时候。最简单的开始是打开宏录制器并执行操作。这将生成一些代码，您可以修改这些代码并将其放入一个循环中。我尝试过，但有两点被阻止：1。选择单元格的范围已定义，我希望在下一个空单元格和2之前有连续单元格的相对范围。如何使循环“当我找到一个空单元格时，我开始取消选择范围，然后将其转置，然后找到下一个空单元格…感谢您的回答-我在“lastRangeRow=.Cells（i，copyCol）.End（xlDown）.Row”上出现溢出错误“这是pb:-LastRangeRow值为'0'的打印屏幕，它可以工作！当我把打印屏幕，我注意到你有2列-我已经改变了copycol为1和'2'的范围和魔术非常感谢你为我节省了几个小时
  Sub test()
    Dim lastRangeRow As Integer, lastRow As Integer, i As Integer, copyCol As Integer
    Dim noOfReports As Integer

    copyCol = 2 'Column "B" has the info you want to transpose.  Change if different
    lastRow = Sheets("Sheet1").UsedRange.Rows.Count

    '  How many blank cells are there? This will tell us how many times to run the macro
    noOfReports = Range(Cells(1, 1), Cells(lastRow, 1)).SpecialCells(xlCellTypeBlanks).Cells.Count + 1

i = 1
Do While i <= lastRow 'until you reach the last row, transpose the data
    With Sheets("Sheet1")
        lastRangeRow = .Cells(i, copyCol).End(xlDown).Row
        .Range(.Cells(i, copyCol), .Cells(lastRangeRow, 2)).Copy
        .Cells(i, copyCol + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

        If lastRangeRow >= lastRow Then
            Exit Do
        Else
            i = .Cells(i, copyCol).End(xlDown).End(xlDown).Row
        End If
    End With
Loop

MsgBox ("Done!")
Application.CutCopyMode = False

End Sub