VBA按用户与周数匹配粘贴数据及代码优化问题

需求说明 #

将Scorecard工作表AD13单元格的数值，按以下规则粘贴到目标位置：

• 匹配Scorecard!D2的用户名，在Yearly工作表A列确定目标行
• 匹配Scorecard!V2的周数，在Yearly工作表的列确定目标列

同时修复现有代码的两个问题：

1. Scorecard!B29为空时添加注释报错
2. Yearly工作表目标单元格非空时禁止覆盖已提交分数

同工作簿实现代码 #

Sub PasteScore_SameWorkbook()
    Dim wsScorecard As Worksheet
    Dim wsYearly As Worksheet
    Dim userName As String
    Dim weekNum As String
    Dim targetRow As Variant
    Dim targetCol As Variant
    Dim targetCell As Range
    Dim commentText As String
    
    ' 初始化工作表对象
    Set wsScorecard = ThisWorkbook.Worksheets("Scorecard")
    Set wsYearly = ThisWorkbook.Worksheets("Yearly")
    
    ' 获取关键值
    userName = wsScorecard.Range("D2").Value
    weekNum = wsScorecard.Range("V2").Value
    commentText = wsScorecard.Range("B29").Value
    
    ' 校验必填参数
    If userName = "" Or weekNum = "" Then
        MsgBox "用户名或周数不能为空！", vbExclamation
        Exit Sub
    End If
    
    ' 匹配目标行（用户名）
    On Error Resume Next
    targetRow = Application.Match(userName, wsYearly.Columns("A"), 0)
    On Error GoTo 0
    If IsError(targetRow) Then
        MsgBox "未找到用户名：" & userName, vbCritical
        Exit Sub
    End If
    
    ' 匹配目标列（周数）
    On Error Resume Next
    targetCol = Application.Match(weekNum, wsYearly.Rows(1), 0) ' 假设周数在第1行，可根据实际调整
    On Error GoTo 0
    If IsError(targetCol) Then
        MsgBox "未找到周数：" & weekNum, vbCritical
        Exit Sub
    End If
    
    ' 定位目标单元格
    Set targetCell = wsYearly.Cells(targetRow, targetCol)
    
    ' 禁止覆盖非空单元格
    If Not IsEmpty(targetCell.Value) Then
        MsgBox "目标单元格已存在分数，禁止覆盖！", vbExclamation
        Exit Sub
    End If
    
    ' 粘贴分数
    targetCell.Value = wsScorecard.Range("AD13").Value
    
    ' 添加注释（处理B29为空的情况）
    If commentText <> "" Then
        ' 先删除原有注释（如果有）
        If Not targetCell.Comment Is Nothing Then
            targetCell.Comment.Delete
        End If
        targetCell.AddComment Text:=commentText
    End If
    
    MsgBox "分数提交成功！", vbInformation
End Sub

代码关键点说明 #

• 禁止覆盖逻辑：通过IsEmpty(targetCell.Value)判断目标单元格是否为空，非空则直接提示并退出
• 注释报错修复：先判断B29的内容是否为空，仅当有内容时才执行添加注释操作；同时先删除目标单元格原有注释，避免重复添加报错
• 匹配错误处理：使用On Error Resume Next捕获Match函数的查找失败，返回错误时提示用户

未打开外部工作簿实现代码 #

Sub PasteScore_ExternalWorkbook()
    Dim wsScorecard As Worksheet
    Dim externalWb As Workbook
    Dim wsYearly As Worksheet
    Dim userName As String
    Dim weekNum As String
    Dim targetRow As Variant
    Dim targetCol As Variant
    Dim targetCell As Range
    Dim commentText As String
    Dim externalPath As String
    
    ' 设置外部工作簿路径（请替换为实际路径）
    externalPath = "C:\YourPath\YearlyData.xlsx"
    
    ' 初始化当前工作表对象
    Set wsScorecard = ThisWorkbook.Worksheets("Scorecard")
    
    ' 获取关键值
    userName = wsScorecard.Range("D2").Value
    weekNum = wsScorecard.Range("V2").Value
    commentText = wsScorecard.Range("B29").Value
    
    ' 校验必填参数
    If userName = "" Or weekNum = "" Then
        MsgBox "用户名或周数不能为空！", vbExclamation
        Exit Sub
    End If
    
    ' 打开外部工作簿（只读模式，避免锁定）
    On Error Resume Next
    Set externalWb = Workbooks.Open(externalPath, ReadOnly:=False) ' 需要写入权限则设为False
    On Error GoTo 0
    If externalWb Is Nothing Then
        MsgBox "无法打开外部工作簿，请检查路径是否正确！", vbCritical
        Exit Sub
    End If
    
    ' 初始化外部工作表对象
    Set wsYearly = externalWb.Worksheets("Yearly")
    
    ' 匹配目标行（用户名）
    On Error Resume Next
    targetRow = Application.Match(userName, wsYearly.Columns("A"), 0)
    On Error GoTo 0
    If IsError(targetRow) Then
        MsgBox "未找到用户名：" & userName, vbCritical
        externalWb.Close SaveChanges:=False
        Exit Sub
    End If
    
    ' 匹配目标列（周数）
    On Error Resume Next
    targetCol = Application.Match(weekNum, wsYearly.Rows(1), 0) ' 假设周数在第1行，可根据实际调整
    On Error GoTo 0
    If IsError(targetCol) Then
        MsgBox "未找到周数：" & weekNum, vbCritical
        externalWb.Close SaveChanges:=False
        Exit Sub
    End If
    
    ' 定位目标单元格
    Set targetCell = wsYearly.Cells(targetRow, targetCol)
    
    ' 禁止覆盖非空单元格
    If Not IsEmpty(targetCell.Value) Then
        MsgBox "目标单元格已存在分数，禁止覆盖！", vbExclamation
        externalWb.Close SaveChanges:=False
        Exit Sub
    End If
    
    ' 粘贴分数
    targetCell.Value = wsScorecard.Range("AD13").Value
    
    ' 添加注释（处理B29为空的情况）
    If commentText <> "" Then
        If Not targetCell.Comment Is Nothing Then
            targetCell.Comment.Delete
        End If
        targetCell.AddComment Text:=commentText
    End If
    
    ' 保存并关闭外部工作簿
    externalWb.Close SaveChanges:=True
    MsgBox "分数提交成功！", vbInformation
End Sub

代码关键点说明 #

• 外部工作簿处理：通过Workbooks.Open打开指定路径的工作簿，操作完成后自动保存并关闭
• 权限控制：根据实际需求设置ReadOnly参数，需要写入时设为False
• 错误兜底：任何步骤失败都会关闭外部工作簿并提示，避免文件锁定

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