如何在VBA的if语句中实现部分匹配并完成动态求和？

核心思路 #

• 先定位2020列的位置（通过表头匹配，适配报表结构变化）
• 从第2行开始遍历A列，按每2行一组检查部分匹配
• 用InStr函数实现文本部分匹配，判断当前行与下一行是否包含相同关键词
• 若匹配则求和两行的2020列数值；若不匹配则仅取当前行数值
• 动态获取A列最后一行，适配每周更新的报表

完整代码示例 #

Sub PartialMatchSum()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim col2020 As Integer
    Dim i As Long
    Dim currentText As String
    Dim nextText As String
    Dim sumResult As Double
    Dim targetKeyword As String
    
    ' 指定目标工作表，根据实际修改名称
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' 定位2020列（匹配表头为"2020"的列）
    col2020 = ws.Rows(1).Find(What:="2020", LookIn:=xlValues, LookAt:=xlWhole).Column
    If col2020 = 0 Then
        MsgBox "未找到2020列，请检查表头", vbExclamation
        Exit Sub
    End If
    
    ' 获取A列最后一行
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 从第2行开始遍历处理
    i = 2
    Do While i <= lastRow
        currentText = ws.Cells(i, "A").Value
        sumResult = 0
        targetKeyword = ExtractKeyword(currentText)
        
        ' 检查下一行是否存在且部分匹配
        If i + 1 <= lastRow Then
            nextText = ws.Cells(i + 1, "A").Value
            ' 不区分大小写的部分匹配判断
            If InStr(1, nextText, targetKeyword, vbTextCompare) > 0 Then
                ' 两行匹配，求和
                sumResult = ws.Cells(i, col2020).Value + ws.Cells(i + 1, col2020).Value
                ws.Cells(i, "C").Value = sumResult ' 结果输出到C列，可自行修改
                ws.Cells(i + 1, "C").Value = sumResult ' 可选：两行都显示结果
                i = i + 2 ' 跳过下一行，处理下一组
            Else
                ' 下一行不匹配，仅取当前行数值
                sumResult = ws.Cells(i, col2020).Value
                ws.Cells(i, "C").Value = sumResult
                i = i + 1
            End If
        Else
            ' 最后一行单独处理
            sumResult = ws.Cells(i, col2020).Value
            ws.Cells(i, "C").Value = sumResult
            i = i + 1
        End If
    Loop
    
    MsgBox "求和完成", vbInformation
End Sub

' 辅助函数：提取文本中的核心关键词（默认取第一个单词，可按需修改）
Function ExtractKeyword(cellText As String) As String
    ' 示例：从"Jon Smith"提取"Jon"，若名称格式不同可调整逻辑
    ExtractKeyword = Split(cellText, " ")(0)
    
    ' 若需匹配预设名称列表，可替换为以下逻辑：
    ' Dim keywords As Variant
    ' keywords = Array("Jon", "Mary", "Ben", "Chip")
    ' For Each kw In keywords
    '     If InStr(1, cellText, kw, vbTextCompare) > 0 Then
    '         ExtractKeyword = kw
    '         Exit Function
    '     End If
    ' Next kw
    ' ExtractKeyword = cellText
End Function

代码说明 #

1. 动态列定位：用Find函数查找2020列，避免硬编码列号，适配报表结构变动
2. 部分匹配实现：InStr搭配vbTextCompare参数，实现不区分大小写的包含匹配，比如"Jon Doe"和"Jon Smith"都会被识别为匹配
3. 灵活遍历逻辑：用Do While循环处理所有行，兼容最后一行单独存在的情况
4. 关键词提取：辅助函数ExtractKeyword可根据实际名称格式调整，比如从"Doe, Jon"提取关键词，或匹配预设名称列表

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