如何用VBA将Excel主工作表行按E列CVE关键词移动到对应工作表

完整修正代码 #

Public WSNames() As String
Public WSNum() As Long
Public I As Long
Public ShtCount As Long

Sub MoveBasedOnValue()
    Dim CVETitle As String
    Dim xRg As Range
    Dim A As Long
    Dim keyWordIdx As Long
    Dim rowIdx As Long
    Dim targetLastRow As Long
    Dim countCop As Long
    Dim indexMatchRow As Long
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 读取工作表名索引
    ReadWSNames
    
    ' 获取主表待扫描的行数范围
    A = Worksheets("Main").UsedRange.Rows.Count
    Set xRg = Worksheets("Main").Range("E5:E" & A)

    ' 外层循环：遍历所有关键词工作表（排除Index和Main）
    For keyWordIdx = 1 To UBound(WSNames)
        ' 跳过Index和Main表
        If WSNames(keyWordIdx) = "Index" Or WSNames(keyWordIdx) = "Main" Then GoTo NextKeyword
        
        ' 获取当前关键词对应工作表的最后一行
        targetLastRow = Worksheets(WSNames(keyWordIdx)).UsedRange.Rows.Count
        If targetLastRow < 5 Then targetLastRow = 4 ' 保证数据从第5行开始写入，匹配原有格式
        
        ' 内层循环：倒序遍历主表行，避免删行导致的漏判
        For rowIdx = xRg.Count To 1 Step -1
            CVETitle = CStr(xRg(rowIdx).Value)
            ' 匹配关键词，vbTextCompare代表不区分大小写，可根据需求删除该参数改为区分大小写
            If InStr(1, CVETitle, WSNames(keyWordIdx), vbTextCompare) > 0 Then
                ' 复制行到目标工作表
                xRg(rowIdx).EntireRow.Copy Destination:=Worksheets(WSNames(keyWordIdx)).Range("A" & targetLastRow + 1)
                targetLastRow = targetLastRow + 1
                
                ' 更新Index表对应关键词的计数
                indexMatchRow = Application.Match(WSNames(keyWordIdx), Worksheets("Index").Range("A:A"), 0)
                If Not IsError(indexMatchRow) Then
                    countCop = Worksheets("Index").Range("B" & indexMatchRow).Value
                    Worksheets("Index").Range("B" & indexMatchRow).Value = countCop + 1
                End If
                
                ' 删除主表已匹配的行
                xRg(rowIdx).EntireRow.Delete
            End If
        Next rowIdx
NextKeyword:
    Next keyWordIdx

    ' 清理主表剩余数据仅保留表头，可根据实际表头行数调整删除起始行号
    If Worksheets("Main").UsedRange.Rows.Count > 4 Then
        Worksheets("Main").Range("5:" & Worksheets("Main").UsedRange.Rows.Count).EntireRow.Delete
    End If

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub


Sub ReadWSNames()
    ReDim WSNames(1 To ActiveWorkbook.Sheets.Count)
    ReDim WSNum(1 To ActiveWorkbook.Sheets.Count)
    
    ShtCount = Sheets.Count

   '读取工作表名和行数到数组，清空非主表的旧数据
    If Not IndexExists("Index") Then
        For I = 1 To ShtCount
            WSNames(I) = Sheets(I).Name
            If WSNames(I) <> "Main" Then ActiveWorkbook.Worksheets(WSNames(I)).Range("5:10000").EntireRow.Delete
            WSNum(I) = Worksheets(WSNames(I)).UsedRange.Rows.Count
            WSNum(I) = WSNum(I) - 3
        Next I
        ' 新增Index表
        Worksheets.Add Before:=Worksheets(1)
        ActiveSheet.Name = "Index"
        Application.DefaultSheetDirection = xlLTR
        ' 写入表头
        Range("A1").Value = "WS Names"
        Range("B1").Value = "Count"
        With Range("A1:B1")
            .Font.Size = 14
            .Font.Bold = True
            .Font.Color = vbBlue
        End With
        Columns("A:B").AutoFit
        Columns("B:B").HorizontalAlignment = xlCenter
        ' 写入初始数据
        Range("A2").Select
        For I = 1 To ShtCount
            ActiveCell.Value = WSNames(I)
            ActiveCell.Offset(0, 1) = WSNum(I)
            ActiveCell.Offset(1, 0).Select
        Next I
        ' 重新读取数组
        Worksheets("Index").Activate
        Range("A2").Select
        I = 1
        X = 2
        Do While Not IsEmpty(Range("A" & X))
            WSNames(I) = ActiveCell.Value
            WSNum(I) = ActiveCell.Offset(0, 1).Value
            ActiveCell.Offset(1, 0).Select
            I = I + 1
            X = X + 1
        Loop
        Worksheets("Main").Activate
    Else
        ' Index表已存在时直接读取数组
        Worksheets("Index").Activate
        Range("A2").Select
        I = 1
        X = 2
        Do While Not IsEmpty(Range("A" & X))
            WSNames(I) = ActiveCell.Value
            WSNum(I) = ActiveCell.Offset(0, 1).Value
            ActiveCell.Offset(1, 0).Select
            I = I + 1
            X = X + 1
        Loop
        Worksheets("Main").Activate
    Exit Sub
    End If
    
End Sub


Function IndexExists(sSheet As String) As Boolean
On Error Resume Next
    IndexExists = (ActiveWorkbook.Sheets(sSheet).Index > 0)
End Function

核心修改说明 #

• 新增外层循环遍历所有从Index表读取的关键词，自动跳过Index和Main两个系统工作表
• 主表行遍历改为倒序，解决正序删除行导致的漏判问题
• 动态匹配Index表中对应关键词的计数单元格，不再固定写死B3位置
• 新增可选的不区分大小写匹配逻辑，可根据需求调整
• 所有匹配完成后自动清理主表剩余数据，仅保留表头
• 修复了原IndexExists函数返回值错误的问题

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