为每条记录添加表头为行：Excel格式转换VBA代码修复求助

我收到一份Excel文件，原格式为：

需要将其转换为如下目标格式：

我编写了如下VBA代码，但无法正常运行，请求帮助排查修复：

Sub Format_Click()

Dim ws1 As Worksheet
Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet
Set ws2 = Sheets("Sheet2")
Dim count As Integer
Dim rng As Range
Set rng = ws1.UsedRange
ws2.Cells(1, 1) = "Contract"
ws2.Cells(1, 2) = "Code"
ws2.Cells(1, 3) = "Price"

For i = 1 To rng.Columns.count
For j = 2 To rng.Rows.count
count = ws2.Range("A" & ws2.Rows.count).End(xlUp).Row
ws2.Cells(count + 1, 1) = rng.Cells(1, i)
ws2.Cells(count + 1, 2) = rng.Cells(j, i)
ws2.Cells(count + 1, 3) = rng.Cells(j, 1)
Next j
Next i

End Sub

代码问题分析 #

1. 循环范围错误：原代码i从1开始遍历所有列，会把原表第一列的“Code”表头误当作“Contract”写入目标表，应该从第2列开始遍历（跳过Code列）。
2. 数据赋值顺序颠倒：目标表第二列是Code、第三列是Price，但原代码把交叉单元格内容写入Code列，把Code列内容写入Price列，完全搞反。
3. 未声明循环变量：i和j未显式声明，VBA会默认设为变体类型，可能引发意外问题。
4. 效率低下且易出错：每次循环都通过End(xlUp)查找最后一行，不仅效率低，还可能因目标表存在空行导致数据写入位置错误。

修复后的代码 #

Sub Format_Click()
    Dim ws1 As Worksheet
    Set ws1 = Sheets("Sheet1")
    Dim ws2 As Worksheet
    Set ws2 = Sheets("Sheet2")
    Dim count As Integer
    Dim rng As Range
    Dim i As Integer, j As Integer ' 显式声明循环变量
    
    Set rng = ws1.UsedRange
    ws2.Cells.Clear ' 清空目标表原有数据，避免重复运行时数据叠加
    ' 设置目标表表头
    ws2.Cells(1, 1) = "Contract"
    ws2.Cells(1, 2) = "Code"
    ws2.Cells(1, 3) = "Price"
    
    count = 1 ' 从表头下一行开始计数
    
    ' 遍历所有Contract列（从第2列开始，跳过Code列）
    For i = 2 To rng.Columns.count
        ' 遍历所有Code行（从第2行开始，跳过表头行）
        For j = 2 To rng.Rows.count
            count = count + 1
            ws2.Cells(count, 1) = rng.Cells(1, i) ' 写入Contract名称
            ws2.Cells(count, 2) = rng.Cells(j, 1) ' 写入Code编号
            ws2.Cells(count, 3) = rng.Cells(j, i) ' 写入对应Price
        Next j
    Next i
End Sub

修复说明 #

• 补充循环变量声明，符合VBA编码规范。
• 调整i的起始值为2，只遍历原表中代表Contract的列。
• 修正数据赋值顺序，匹配目标表的列顺序。
• 用递增的count变量定位写入行，替代低效的End(xlUp)查找，同时避免空行干扰。
• 增加ws2.Cells.Clear，确保每次运行代码时目标表都是干净的状态（可根据需求移除）。

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