如何用Excel VBA基于字符“{”转置含重复对象的二维列表

原代码核心问题 #

• 未定义变量lRow：代码中After:=Range("A" & lRow)的lRow未声明赋值，导致查找起始位置错误，无法正常定位第一个“{”。
• FindNext逻辑混乱：循环中多次调用.FindNext(b)会导致查找指针异常跳变，无法稳定遍历所有“{”标记。
• 转置范围与偏移错误：原代码错误地将两个“{”之间的范围作为转置对象，且固定Offset(-3,1)的偏移逻辑未匹配实际区块结构。
• 行处理顺序错误：从上往下删除行时，后续行号会因上移错乱，导致部分区块被遗漏。

修正后的代码 #

Sub TransposeByBrace()
    Dim ws As Worksheet
    Dim findRange As Range
    Dim firstAddr As String
    Dim titleRow As Range
    Dim transposeRange As Range
    
    ' 绑定目标工作表
    Set ws = ThisWorkbook.Sheets("Results")
    
    ' 从A列查找第一个"{",匹配整单元格内容
    Set findRange = ws.Columns("A").Find(What:="{", LookIn:=xlValues, LookAt:=xlWhole)
    
    If Not findRange Is Nothing Then
        firstAddr = findRange.Address
        ' 从下往上处理，避免删除行导致的行号错乱
        Do
            ' 匹配区块结构：标题行（{行向上4行），待转置数据行（{行向上3到向上1行）
            Set titleRow = ws.Cells(findRange.Row - 4, "A")
            Set transposeRange = ws.Range(ws.Cells(findRange.Row - 3, "A"), ws.Cells(findRange.Row - 1, "A"))
            
            ' 将竖排数据转置到标题行右侧
            transposeRange.Copy
            titleRow.Offset(0, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
            
            ' 删除原数据行和{分隔行（共4行）
            ws.Range(ws.Cells(findRange.Row - 3, "A"), findRange).Delete Shift:=xlUp
            
            ' 继续查找下一个"{",因行已删除，重新定位
            Set findRange = ws.Columns("A").FindNext(findRange)
        ' 循环直到回到第一个"{",避免无限循环
        Loop While Not findRange Is Nothing And findRange.Address <> firstAddr
    End If
    
    ' 清除剪贴板状态
    Application.CutCopyMode = False
End Sub

代码关键说明 #

• 从下往上处理：删除行后下方行会自动上移，从下往上遍历可避免行号错乱，确保每个区块都被正确识别。
• 精准匹配区块：根据转置前后的结构，每个区块包含1行标题、3行数据、1行“{”分隔符，通过行偏移精准定位对应范围。
• 稳定查找逻辑：记录第一个“{”的地址，循环终止条件设为回到起始位置，避免无限循环。
• 清理剪贴板：转置完成后清除剪贴板，消除Excel的复制状态提示。

内容的提问来源于stack exchange，提问作者RyCar66