VBA 程序按列，我想保留第一行和第二行，该怎么修改代码，目前只保留了第一行在新的表格里

Question

Sub 保留表头拆分数据为若干新工作簿()

' 弹出输入框让用户输入拆分列号
c = Application.InputBox("请输入拆分列号", , 4, , , , , 1)
If c = 0 Then Exit Sub
' 禁用屏幕更新和警告
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' 获取当前区域数组
arr = [a1].CurrentRegion
lc = UBound(arr, 2)
' 设置拆分列的标题行
Set rng = [a1].Resize(1, lc)
' 创建字典对象
Set d = CreateObject("scripting.dictionary")
' 从第三行开始遍历数组
For i = 3 To UBound(arr)
    If Not d.Exists(arr(i, c)) Then
        ' 如果字典中不存在该键，则添加键和对应的行
        Set d(arr(i, c)) = Cells(i, 1).Resize(1, lc)
    Else
        ' 如果字典中已存在该键，则将当前行添加到对应的键下
        Set d(arr(i, c)) = Union(d(arr(i, c)), Cells(i, 1).Resize(1, lc))
    End If
Next
' 获取字典的键和项
k = d.Keys
t = d.Items
' 遍历字典，为每个键创建一个新的工作簿
For i = 0 To d.Count - 1
    With Workbooks.Add(xlWBATWorksheet)
        ' 复制标题行
        rng.Copy .Sheets(1).[a1]
        ' 复制对应键的数据行
        t(i).Copy .Sheets(1).[a3] ' 从第三行开始复制
        ' 保存新工作簿
        .SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & ".xls"
        .Close
    End With
Next
' 启用屏幕更新和警告
Application.DisplayAlerts = True
Application.ScreenUpdating = True
' 显示完成消息
MsgBox "拆分完毕"

End Sub

Answer 1

引自免费微信小程序：皆我百晓生

为了实现保留第一行和第二行的功能，您可以在复制数据行时从第二行（索引为2）开始，而不是从第三行（索引为3）开始。以下是修改后的代码段：

...
' 遍历字典，为每个键创建一个新的工作簿
For i = 0 To d.Count - 1
    With Workbooks.Add(xlWBATWorksheet)
        ' 复制标题行
        rng.Copy .Sheets(1).[a1]
        ' 复制对应键的数据行，从第二行（索引为2）开始
        t(i).Offset(1, 0).Copy .Sheets(1).[a2] ' 从第二行开始复制
        ' 保存新工作簿
        .SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & ".xls"
        .Close
    End With
Next
...

这段代码中的主要变动是这行：

t(i).Offset(1, 0).Copy .Sheets(1).[a2] ' 从第二行开始复制

这里使用了 .Offset(1, 0) 来跳过第一行，并从第二行（索引为2）开始复制数据。

这样，您的整个VBA宏将会保留原表的第一行和第二行内容。记得将上述代码替换到原始宏中相应的位置。