求Excel VBA代码：将可变行数的样本数据按索引转置为列

需求说明 #

现有表格包含三列：Sample、Index、Value，样本数量和可选Index的数量会动态变化，每个样本对应的已测Index数量不固定，需要将数据转置为每个样本一行，每个Index作为列，对应填充Value的格式。

VBA代码实现 #

Sub TransposeSampleIndexValue()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim sampleDict As Object, indexList As Collection
    Dim currentSample As String, currentIndex As String
    Dim targetRow As Long, targetCol As Long
    
    ' 设置源工作表和目标工作表（可根据实际修改）
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    Set wsTarget = ThisWorkbook.Worksheets.Add(After:=wsSource)
    wsTarget.Name = "转置结果"
    
    ' 获取源数据最后一行
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' 创建字典存储每个样本的索引-值映射，集合存储所有唯一索引
    Set sampleDict = CreateObject("Scripting.Dictionary")
    Set indexList = New Collection
    
    ' 遍历源数据，收集唯一样本、唯一索引，以及对应的值
    On Error Resume Next ' 忽略集合重复添加的错误
    For i = 2 To lastRow ' 假设第一行是表头
        currentSample = wsSource.Cells(i, "A").Value
        currentIndex = wsSource.Cells(i, "B").Value
        
        ' 添加唯一索引到集合
        indexList.Add currentIndex, Key:=CStr(currentIndex)
        
        ' 若字典中无当前样本，创建新的子字典存储索引-值
        If Not sampleDict.Exists(currentSample) Then
            Set sampleDict(currentSample) = CreateObject("Scripting.Dictionary")
        End If
        ' 存储当前样本的索引对应值
        sampleDict(currentSample)(currentIndex) = wsSource.Cells(i, "C").Value
    Next i
    On Error GoTo 0 ' 恢复错误处理
    
    ' 写入目标表表头
    wsTarget.Cells(1, 1).Value = "Sample"
    For j = 1 To indexList.Count
        wsTarget.Cells(1, j + 1).Value = indexList(j)
    Next j
    
    ' 写入每个样本的数据
    targetRow = 2
    For Each currentSample In sampleDict.Keys
        wsTarget.Cells(targetRow, 1).Value = currentSample
        ' 遍历所有索引，填充对应值，无数据则留空
        For j = 1 To indexList.Count
            currentIndex = indexList(j)
            If sampleDict(currentSample).Exists(currentIndex) Then
                wsTarget.Cells(targetRow, j + 1).Value = sampleDict(currentSample)(currentIndex)
            Else
                wsTarget.Cells(targetRow, j + 1).Value = ""
            End If
        Next j
        targetRow = targetRow + 1
    Next currentSample
    
    ' 自动调整列宽
    wsTarget.Columns.AutoFit
    
    MsgBox "转置完成！结果已保存到工作表：" & wsTarget.Name, vbInformation
End Sub

使用说明 #

• 打开目标Excel文件，按下Alt + F11打开VBA编辑器
• 插入新模块：右键点击项目窗口中的工作簿名称 → 插入 → 模块
• 将上述代码粘贴到模块中，修改wsSource = ThisWorkbook.Worksheets("Sheet1")里的Sheet1为你的源数据工作表名称
• 运行宏：按下F5，或回到Excel界面通过「开发工具」→「宏」选择TransposeSampleIndexValue执行

代码特点 #

• 完全动态适配任意数量的样本和Index，无需手动修改固定行数/列数
• 自动收集唯一的样本和索引，避免重复数据干扰
• 样本未测的Index自动留空，保证表格结构规整
• 自动调整结果表列宽，提升可读性

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