将跨工作簿复制数据的VBA代码改写为带参数的类UDF函数

改写思路 #

把原按钮事件里硬编码的固定逻辑（工作表名、列映射、起始行）提取为可配置参数，同时简化重复的复制粘贴代码，优化数据行判断逻辑避免空行误判，增加基础错误处理提升稳定性。

改写后的代码 #

' 带参数的数据导入函数，可在宏或其他代码中调用
Sub ImportProjectData(sourceFilePath As String, _
                      sourceSheetName As String, _
                      targetSheetName As String, _
                      Optional startRowSource As Long = 7, _
                      Optional startRowTarget As Long = 5)
    Dim sourceWb As Workbook
    Dim targetWb As Workbook
    Dim sourceWs As Worksheet
    Dim targetWs As Worksheet
    Dim sourceLastRow As Long
    Dim targetLastRow As Long
    Dim colMappings As Variant
    Dim i As Integer
    
    ' 初始化目标工作簿为当前活动工作簿
    Set targetWb = ActiveWorkbook
    
    ' 检查文件是否存在
    If Dir(sourceFilePath) = "" Then
        MsgBox "指定文件不存在！", vbCritical
        Exit Sub
    End If
    
    ' 检查目标工作表是否存在
    On Error Resume Next
    Set targetWs = targetWb.Worksheets(targetSheetName)
    On Error GoTo 0
    If targetWs Is Nothing Then
        MsgBox "目标工作表 '" & targetSheetName & "' 不存在！", vbCritical
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    ' 只读打开源工作簿
    Set sourceWb = Workbooks.Open(Filename:=sourceFilePath, ReadOnly:=True)
    
    ' 检查源工作表是否存在
    On Error Resume Next
    Set sourceWs = sourceWb.Worksheets(sourceSheetName)
    On Error GoTo 0
    If sourceWs Is Nothing Then
        MsgBox "源工作表 '" & sourceSheetName & "' 不存在！", vbCritical
        sourceWb.Close SaveChanges:=False
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    ' 获取源数据最后一行（从A列向上查找，避免空行误判）
    sourceLastRow = sourceWs.Cells(sourceWs.Rows.Count, "A").End(xlUp).Row
    ' 源起始行大于最后一行，说明无有效数据
    If sourceLastRow < startRowSource Then
        MsgBox "源工作表中无有效数据！", vbExclamation
        sourceWb.Close SaveChanges:=False
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    ' 获取目标工作表最后一行（从A列向上查找）
    targetLastRow = targetWs.Cells(targetWs.Rows.Count, "A").End(xlUp).Row
    ' 调整目标粘贴起始行
    If targetLastRow < startRowTarget Then
        targetLastRow = startRowTarget
    Else
        targetLastRow = targetLastRow + 1 ' 跳到下一行粘贴新数据
    End If
    
    ' 定义源列与目标列的映射关系（顺序：源列, 目标列）
    colMappings = Array( _
        "B", "A", _
        "C", "C", _
        "D", "E", _
        "E", "F", _
        "F", "G", _
        "G", "H", _
        "H", "I", _
        "I", "J", _
        "J", "K", _
        "K", "L", _
        "L", "M", _
        "M", "N", _
        "N", "O", _
        "O", "P", _
        "P", "Q", _
        "Q", "R", _
        "R", "BL", _
        "S", "BM", _
        "T", "BN", _
        "U", "BO", _
        "V", "BP", _
        "W", "BQ", _
        "X", "BR", _
        "Y", "BS", _
        "Z", "BT", _
        "AA", "BU", _
        "AB", "BV" _
    )
    
    ' 循环处理列映射，复制粘贴数据
    For i = LBound(colMappings) To UBound(colMappings) Step 2
        sourceWs.Range(colMappings(i) & startRowSource, colMappings(i) & sourceLastRow).Copy
        targetWs.Range(colMappings(i + 1) & targetLastRow).PasteSpecial Paste:=xlPasteValues
    Next i
    
    ' 清理剪贴板并恢复屏幕更新
    Application.CutCopyMode = False
    sourceWb.Close SaveChanges:=False
    Application.ScreenUpdating = True
    
    MsgBox "数据导入完成！", vbInformation
End Sub

' 示例：保留原按钮的文件选择功能，调用带参数的导入函数
Private Sub Btn_Load_Test_Data_file_Click()
    Dim filePath As String
    
    ' 弹出文件选择对话框
    filePath = Application.GetOpenFilename("Excel文件 (*.xlsx;*.xls), *.xlsx;*.xls")
    If filePath = "False" Then
        Beep
        Exit Sub
    End If
    
    ' 调用导入函数，传入固定参数（可按需修改）
    ImportProjectData filePath, "Projects", "Projects"
End Sub

代码说明 #

1. 参数说明：
   • sourceFilePath：必填，外部Excel文件的完整路径
   • sourceSheetName：必填，源数据所在的工作表名称
   • targetSheetName：必填，当前工作簿中接收数据的工作表名称
   • startRowSource：可选，源数据的起始行，默认7
   • startRowTarget：可选，目标数据的起始参考行，默认5
2. 优化点：
   • 用循环处理列映射替代重复的复制粘贴代码，更简洁易维护
   • 改用Cells(Rows.Count, 列).End(xlUp).Row获取最后一行，避免空行导致的错误
   • 增加文件、工作表存在性检查，防止运行时崩溃
   • 只读打开源工作簿，避免文件锁定冲突
3. 使用方式：
   • 可直接在其他宏中调用ImportProjectData并传入自定义参数
   • 保留原按钮功能，通过文件选择对话框获取路径后自动调用导入函数

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