基于条件的Excel VBA转置宏实现求助：大范围内仅转置前4行数据

• 先确定匹配规则：默认以数据源A列的分类作为匹配条件，你可以根据实际需求调整条件列
• 遍历数据源时给每个分类单独计数，仅保留每个分类下符合条件的前4条数值
• 所有匹配值收集完成后批量转置写入目标工作表，避免逐行写入卡顿，适配大数据量场景

Sub 条件转置前4行()
    Dim 数据源表 As Worksheet, 目标表 As Worksheet
    Dim 数据最后行 As Long, 目标行 As Long, i As Long
    Dim 当前分类 As String, 计数 As Integer
    Dim 结果数组 As Variant
    
    ' 配置参数，可根据实际情况修改
    Set 数据源表 = ThisWorkbook.Sheets("Sheet1") ' 替换为你的数据源工作表名
    Set 目标表 = ThisWorkbook.Sheets("Example #2") ' 替换为你的目标工作表名
    数据最后行 = 数据源表.Cells(Rows.Count, "A").End(xlUp).Row ' 条件列是A列，对应取值列是B列
    目标行 = 1 ' 目标表从第1行开始写
    
    ' 先获取所有不重复的分类
    Dim 分类字典 As Object
    Set 分类字典 = CreateObject("Scripting.Dictionary")
    
    For i = 5 To 数据最后行 ' 数据源从第5行开始，和你原代码的起始位置一致
        当前分类 = 数据源表.Cells(i, "A").Value
        If Not 分类字典.Exists(当前分类) Then
            分类字典.Add 当前分类, New Collection
        End If
        ' 仅收集前4条符合条件的数值
        If 分类字典(当前分类).Count < 4 Then
            分类字典(当前分类).Add 数据源表.Cells(i, "B").Value
        End If
    Next i
    
    ' 把收集到的内容写入目标表
    Dim 分类 As Variant
    For Each 分类 In 分类字典.Keys
        目标表.Cells(目标行, "A").Value = 分类
        ReDim 结果数组(1 To 1, 1 To 4)
        For 计数 = 1 To 分类字典(分类).Count
            结果数组(1, 计数) = 分类字典(分类)(计数)
        Next 计数
        ' 转置写入对应行
        目标表.Cells(目标行, "B").Resize(1, 4).Value = 结果数组
        目标行 = 目标行 + 1
    Next 分类
End Sub

• 如果你的匹配条件不是A列，修改数据源表.Cells(i, "A").Value里的列号即可
• 如果取值不是B列，修改数据源表.Cells(i, "B").Value对应的列号
• 如果要调整保留的行数，把分类字典(当前分类).Count < 4里的4改成你需要的数字即可
• 数据源起始行和目标表起始行都可以根据你的实际表格结构调整

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