VBA迭代提取字符串首词并分类到工作表时遇下标越界问题求助

问题背景 #

我有一份导出数据，名称位于E列，需迭代遍历该列：若为新首词则新建工作表，相同首词的行归入同一工作表。

E列示例数据：

7-ZIP RAR decoder
7-ZIP RAR decoder
7-ZIP RAR decoder
Adobe Acrobat and Reader Arbitrary Code
Adobe Acrobat and Reader Arbitrary Code
Adobe Acrobat and Reader Arbitrary Code
Adobe Acrobat and Reader Arbitrary Code
Adobe Acrobat and Reader Arbitrary Code
Adobe Acrobat and Reader Arbitrary Code
Adobe Security Update for
Adobe Security Update for
Adobe Security Update for
Adobe Security Update for
Autodesk Desktop App
Autodesk Desktop App
Autodesk Desktop App

原VBA代码 #

Sub robbie()
    Dim K As Long
    Dim r As Range
    Dim v As Variant
    K = 1
    Dim firstWord As String
    Dim w1 As Worksheet
    Dim w2 As Worksheet
    Set w1 = Sheets("Export")
    Set w2 = Sheets("Adobe")
    w1.Activate
    For Each r In Intersect(Range("E:E"), ActiveSheet.UsedRange) 
        v = r.Value
        firstWord = Split(v, " ")(0)
        Debug.Print firstWord
        If InStr(v, "firstWord") > 0 Then
            r.Copy w2.Cells(K, 1)
            K = K + 1
        End If
    Next r
End Sub

修改后的循环代码片段 #

For Each r In Intersect(Range("E:E"), ActiveSheet.UsedRange)
    v = r.Value
    If Not IsEmpty(v) Then
        
        firstWord = Split(v, " ")(0)
        Debug.Print firstWord
        
        If InStr(v, "firstWord") > 0 Then

        
        r.Copy w2.Cells(K, 1)
        K = K + 1

        End If
    End If
Next r

遇到的问题 #

将判断值从“7-ZIP”改为变量firstWord时，出现错误：运行时错误'9'：下标越界，但Debug.Print能在立即窗口正确输出所有首词。

错误原因分析 #

• 字符串常量误用：InStr(v, "firstWord")中把变量名用引号包裹，导致程序判断的是单元格内容是否包含字符串"firstWord"，而非变量firstWord的实际值，逻辑完全失效。
• 空白内容过滤不彻底：IsEmpty(v)无法识别仅含空白字符的单元格，这类单元格执行Split(v, " ")(0)时，Split返回空数组，访问下标0就会触发“下标越界”错误。
• 工作表逻辑缺失：原代码固定使用Sheets("Adobe")作为目标工作表，未实现“新首词新建工作表”的核心需求，业务逻辑不完整。

修正后的完整代码 #

Sub robbie()
    Dim K As Long
    Dim r As Range
    Dim v As Variant
    Dim firstWord As String
    Dim w1 As Worksheet
    Dim targetSheet As Worksheet
    Dim sheetExists As Boolean
    
    ' 绑定原数据工作表
    Set w1 = ThisWorkbook.Sheets("Export")
    
    ' 遍历E列已使用区域的单元格
    For Each r In Intersect(w1.Range("E:E"), w1.UsedRange)
        ' 去除单元格内容首尾空白字符
        v = Trim(r.Value)
        
        ' 仅处理非空且非纯空白的内容
        If v <> "" Then
            ' 提取首词
            firstWord = Split(v, " ")(0)
            Debug.Print firstWord
            
            ' 检查目标工作表是否已存在
            sheetExists = False
            For Each targetSheet In ThisWorkbook.Sheets
                If targetSheet.Name = firstWord Then
                    sheetExists = True
                    Exit For
                End If
            Next targetSheet
            
            ' 不存在则新建工作表，命名为对应首词
            If Not sheetExists Then
                Set targetSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                targetSheet.Name = firstWord
            End If
            
            ' 复制当前行到目标工作表的最后一行下方
            r.EntireRow.Copy targetSheet.Cells(targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row + 1, 1)
        End If
    Next r
End Sub

关键修正说明 #

1. 彻底过滤空白：用Trim(r.Value)清除首尾空白，再判断v <> ""，避免处理纯空白单元格导致Split报错。
2. 变量正确引用：去掉firstWord的引号，确保判断逻辑基于变量的实际值。
3. 动态创建工作表：增加工作表存在性检查，自动新建以首词命名的工作表，满足业务需求。
4. 无需激活工作表：直接通过对象引用操作工作表，避免激活操作带来的效率问题与潜在错误。
5. 动态定位目标行：自动找到目标工作表的最后一行，避免固定行号变量K导致的覆盖或遗漏问题。

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