如何将VBA If-Else分支中的重复代码封装为可调用函数？

嘿，这事儿好办！把重复代码抽成可调用的子过程是个绝佳的思路，不仅能减少冗余，以后改逻辑也只需要改一处就行。我来给你演示具体怎么弄：

第一步：提取重复逻辑到独立子过程 #

我们把两个分支里从初始化进度到关闭源工作簿的所有重复代码，封装成一个名为ProcessSourceWorkbook的子过程。这个过程需要接收处理所需的所有参数（比如源/目标工作簿、工作表名称、步骤数等）：

Sub ProcessSourceWorkbook(SrcWb As Workbook, DestWb As Workbook, SourceName As String, DestName As String, steps As Integer, ref As Long)
    Dim completed As Double
    Dim lnCol As Long
    Dim last As Long
    Dim DestSheet As Worksheet
    Dim SrcSheet As Worksheet
    Dim destTotalRows As Long
    Dim i As Integer, j, k As Integer
    Dim destKey As String, sourceKey As String
    
    completed = 0
    Application.StatusBar = "复制进行中..." & Round(completed, 0) & "% 已完成"
    
    ' 查找第ref行最后一个非空单元格
    lnCol = SrcWb.Sheets(SourceName).Cells(ref, Columns.Count).End(xlToLeft).Column
    last = lnCol - 1 ' 获取倒数第二列
    
    Set DestSheet = DestWb.Sheets(DestName)
    Set SrcSheet = SrcWb.Sheets(SourceName)
    
    destTotalRows = DestSheet.Cells(Rows.Count, 1).End(xlUp).Row ' 查找目标工作表第1列最后一个非空单元格
    
    For i = 1 To destTotalRows
        destKey = DestSheet.Cells(i, 1)
        If destKey = "" Then GoTo endFor ' 遍历目标工作表时忽略空值
        
        sourceKey = GetSourceKey(destKey)
        If sourceKey = "" Then GoTo endFor ' 遍历源工作表时忽略不匹配的值
        
        Debug.Print "DestKey", destKey, "SourceKey", sourceKey
        
        ' 查找目标工作表中DestKey所在行
        k = DestSheet.Cells(1, 1).EntireColumn.Find(What:=destKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row
        ' 查找源工作表中SourceKey所在行
        j = SrcSheet.Cells(1, 2).EntireColumn.Find(What:=sourceKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row
        
        Debug.Print j, k
        
        ' 修复原代码潜在bug：明确指定Cells所属的工作表
        Call CopyRange(SrcSheet.Range(SrcSheet.Cells(j, 3), SrcSheet.Cells(j, 3).End(xlToRight)), DestSheet.Cells(k, 2), completed)
        
        completed = completed + (100 / steps)
endFor:
    Next i
    
    SrcWb.Close
    Application.StatusBar = "复制完成"
    DoEvents
End Sub

第二步：简化原分支的逻辑 #

现在你可以把Automate_Estimate里的两个分支大幅简化，只保留各自独特的文件获取逻辑，然后调用上面的子过程：

Sub CopyRange(fromRange As Range, toRange As Range, completed As Double)
    fromRange.Copy
    toRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.StatusBar = "复制进行中..." & Round(completed, 0) & "% 已完成"
    DoEvents
End Sub

Sub Automate_Estimate()
    Dim MyFile As String, Str As String, MyDir As String, DestWb As Workbook, SrcWb As Workbook
    Dim DestName As String
    Dim SourceName As String
    Dim completed As Double
    Dim ref As Long
    Dim answer As Integer
    
    DestName = "x" '目标工作表名称
    SourceName = "y" '源工作表名称
    MyDir = "\Path\" '默认目录路径
    Const steps = 22 '需复制的行数
    ref = 13 'y工作表中“总计”所在行
    
    Set DestWb = ThisWorkbook '设置目标工作簿
    
    ' 禁用部分Excel特性以提升运行速度
    Application.DisplayAlerts = False
    ActiveSheet.DisplayPageBreaks = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    answer = MsgBox("若要选择特定文件请点击是，若使用默认路径请点击否", vbYesNo + vbQuestion, "用户指定路径")
    
    If answer = vbYes Then
        MyFile = Application.GetOpenFilename(FileFilter:="Excel文件,*.xl*;*.xm*")
        If MyFile = "False" Then Exit Sub ' 处理用户取消选择文件的情况
        Set SrcWb = Workbooks.Open(MyFile, UpdateLinks:=0) '打开源工作簿
        
        ' 调用封装的子过程处理核心逻辑
        ProcessSourceWorkbook SrcWb, DestWb, SourceName, DestName, steps, ref
        
    ElseIf answer = vbNo Then
        ' 根据需要修改路径
        MyFile = Dir(MyDir & "Estimate*.xls*") '修改文件扩展名
        ChDir MyDir
        
        ' 循环处理目录下所有匹配的文件（原代码只处理了第一个，这里优化为批量处理）
        Do While MyFile <> ""
            Set SrcWb = Workbooks.Open(MyDir + MyFile, UpdateLinks:=0)
            
            ' 调用封装的子过程处理核心逻辑
            ProcessSourceWorkbook SrcWb, DestWb, SourceName, DestName, steps, ref
            
            MyFile = Dir()
        Loop
    End If
    
    ' 恢复Excel特性
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    ActiveSheet.DisplayPageBreaks = True
End Sub

额外优化说明 #

• 修复了原代码中CopyRange调用时的潜在bug：原代码里Cells(j,3)没有指定所属工作表，可能会因为当前活动表不是源工作表而出错，现在明确加上了SrcSheet.限定符。
• 优化了vbNo分支的逻辑：原代码只处理了目录下第一个匹配的文件，现在改成循环处理所有匹配文件，更符合实际需求。
• 增加了用户取消选择文件的处理：当用户在vbYes分支点击取消时，直接退出子过程，避免后续错误。

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