Excel VBA：将行转换为列

我在一列中有1000行数据，我需要根据粗体的每一行将它们转换为列。粗体之间的行数与字符串值不一致

我已经创建了一个简单的代码，它在测试前100行时工作得非常好。但是，当试图在整个列表或其他部分（甚至50行）中运行它时，它只是在运行时阻塞，因此我必须通过任务管理器非常出色（没有错误消息）

Sub Transpose_by_bold（）
将x、y调整为整数
y=1
对于x=1到2000
如果范围（“B”&x）.Font.Bold=True，范围（“B”&x+1）.Font.Bold=True，则y=1
如果范围（“B”&x）.Font.Bold=True，范围（“B”&x+1）.Font.Bold=False，则
范围（“B”和x+1）.切割范围（“B”和x）.偏移量（0，y）
范围（“B”&x+1）。EntireRow.Delete
y=y+1
x=x-1
如果结束
下一个x
端接头

---

如果您能告诉我这里出了什么问题，我将不胜感激。

请尝试下一个代码。我希望我能推断出你代码的逻辑。特别是，如何使用

y

（增加列以复制每次出现的范围）。。。如果逻辑正确，代码应快速，一次删除所有行：

Sub Transpose_by_bold()
    Dim sh As Worksheet, x As Long, y As Long, rngDel As Range
    
    Set sh = ActiveSheet 'use here your sheet
    y = 1
    For x = 1 To 2000
        If Range("B" & x).Font.Bold = True And Range("B" & x + 1).Font.Bold = True Then y = 1
        If Range("B" & x).Font.Bold = True And Range("B" & x + 1).Font.Bold = False Then
            Range("B" & x).Offset(0, y).Value = Range("B" & x + 1).Value
            If rngDel Is Nothing Then
                Set rngDel = Range("B" & x + 1)
            Else
                Set rngDel = Union(rngDel, Range("B" & x + 1))
            End If
            y = y + 1
        End If
    Next x
    If Not rngDel Is Nothing Then rngDel.EntireRow.Delete xlUp
End Sub

---

您的代码当前处于挂起状态，因为一旦它移动到列表的末尾，X就不会增加，因此它会进入一个无限循环。我没有测试过FaneDuru的代码，所以这可能是答案，但另一种选择是在代码中添加某种类型的转义子句，当代码中出现一些您不希望自然发生的情况时，它会将您跳出，比如计数器if range（“b”&x）.value=“”，当不为true时会重置，当达到某个最大值（例如，10个背靠背空单元格）时，将X设置为等于最大值（本例中为2000）

别忘了，在出现这种奇怪的东西时，你可以用F8单步遍历你的代码，并在“局部变量”窗口中观察你的X和Y值——如果你这样做，X被卡住的事实很快就会显现出来

样本计数器（效率不太高，但可以正常工作）：

我刚刚意识到的另一种选择（编辑以注意这一点）是通过感兴趣的列和工作表的使用范围的交叉点来计算最大可能的行数，然后保留一个计数器，只检查您计算的总行数（由于X=X-1行，现在的X计数器是最终的行数，而不是查看的行数）并在该总行计数器上而不是在X上运行主For循环

---

祝你好运！

我建议的一件事是向后循环，在删除行时总是建议这样做。我正在查找转置部分，但什么也看不到。你说的“转置”是什么意思？如果

B1

为粗体，而

B2

为非粗体，则从

x

中减去1，

x

将为零，这不可能是真的。测试逻辑结果的一种方法是使用

F8

单步执行代码，并观察值的变化，以查看它在应用于2000行之前是否执行了您想要的操作。谢谢太多了！现在我明白了。很高兴我能帮上忙！

Sub Transpose_by_bold()
    Dim x, y As Integer
    Dim Counter as Integer
    y = 1
    For x = 1 To 2000
     If IsEmpty(Range("B" & x + 1)) Then
           Counter = Counter + 1
     Else
           Counter = 0
     End If
     If Counter > 9 Then
         x = 2001
     End If
        If Range("B" & x).Font.Bold = True And Range("B" & x + 1).Font.Bold = True Then y = 1
        If Range("B" & x).Font.Bold = True And Range("B" & x + 1).Font.Bold = False Then
            Range("B" & x + 1).Cut Range("B" & x).Offset(0, y)
            Range("B" & x + 1).EntireRow.Delete

            y = y + 1
            x = x - 1
        End If

  
  Next x
End Sub