Excel VBA技术问询：源工作簿列复制+固定值填充及表头匹配

需求回顾 #

• 从活动工作簿B7单元格指定路径的源工作簿中，复制特定列（如F、G列）到新建工作簿
• 新工作簿表头必须严格遵循顺序：Type、Code、Date、Title、Person
• 将活动工作簿中Type、Code、Date对应的固定值，填充到新工作簿对应列，行数与复制的源数据行数一致

原代码问题分析 #

1. 按遍历顺序追加列，无法对应指定的表头位置
2. 未实现固定值批量填充逻辑
3. 表头写入依赖遍历顺序，无法保证与需求的表头顺序一致

修改后的代码 #

Sub CopyAndFillData()
    Dim wbActive As Workbook, wbSource As Workbook, wbNew As Workbook
    Dim wsActive As Worksheet, wsSource As Worksheet, wsNew As Worksheet
    Dim lastRowSource As Long, dataRowCount As Long
    Dim typeVal As String, codeVal As String, dateVal As String
    Dim sourceTitleCol As String, sourcePersonCol As String
    
    ' 初始化活动工作簿和工作表
    Set wbActive = ThisWorkbook
    Set wsActive = wbActive.Sheets("Sheet1")
    
    ' 检查源文件路径是否为空
    If wsActive.Range("B7").Value = "" Then
        MsgBox "请在B7单元格填写源工作簿路径"
        Exit Sub
    End If
    
    ' 获取固定值和源列映射（对应活动工作簿A2:A6的表头与B2:B6的配置）
    typeVal = wsActive.Range("B2").Value
    codeVal = wsActive.Range("B3").Value
    dateVal = wsActive.Range("B4").Value
    sourceTitleCol = wsActive.Range("B5").Value
    sourcePersonCol = wsActive.Range("B6").Value
    
    ' 打开源工作簿，增加错误判断
    On Error Resume Next
    Set wbSource = Workbooks.Open(wsActive.Range("B7").Value)
    On Error GoTo 0
    If wbSource Is Nothing Then
        MsgBox "源工作簿路径无效或文件无法打开"
        Exit Sub
    End If
    Set wsSource = wbSource.Sheets("Sheet1")
    
    ' 获取源数据行数（以Title列为准，确保数据行数统一）
    lastRowSource = wsSource.Cells(Rows.Count, sourceTitleCol).End(xlUp).Row
    dataRowCount = lastRowSource - 1 ' 减去表头行，得到实际数据行数
    
    ' 创建新工作簿并设置工作表
    Set wbNew = Workbooks.Add
    Set wsNew = wbNew.Sheets("Sheet1")
    
    ' 写入固定顺序的表头
    wsNew.Range("A1:E1").Value = Array("Type", "Code", "Date", "Title", "Person")
    
    ' 批量填充固定值列
    With wsNew
        .Range("A2:A" & dataRowCount + 1).Value = typeVal
        .Range("B2:B" & dataRowCount + 1).Value = codeVal
        .Range("C2:C" & dataRowCount + 1).Value = dateVal
    End With
    
    ' 复制源工作簿的指定列到新工作簿对应位置
    wsSource.Range(sourceTitleCol & "2:" & sourceTitleCol & lastRowSource).Copy wsNew.Range("D2")
    wsSource.Range(sourcePersonCol & "2:" & sourcePersonCol & lastRowSource).Copy wsNew.Range("E2")
    
    ' 处理保存路径，避免拼接错误
    Dim savePath As String
    savePath = Left(wsActive.Range("B7").Value, InStrRev(wsActive.Range("B7").Value, "\")) & "Output.xlsx"
    wbNew.SaveAs savePath
    wbNew.Close False
    wbSource.Close False
    
    ' 释放对象
    Set wbActive = Nothing
    Set wbSource = Nothing
    Set wbNew = Nothing
    
    MsgBox "数据处理完成，文件已保存至：" & savePath
End Sub

关键改动说明 #

• 固定表头写入：直接通过数组写入指定顺序的表头，确保与需求完全一致
• 批量填充优化：利用单元格区域赋值方式一次性填充固定值，比循环更高效
• 精准列定位：明确映射活动工作簿的配置到新工作簿的指定列，避免顺序混乱
• 路径处理优化：提取源工作簿所在目录作为保存路径，防止路径拼接错误
• 错误防护：增加源工作簿打开失败的判断，提升代码健壮性

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