VBA拆分字符串数组后判断逻辑失效问题求助

问题原因分析 #

1. 拆分后字符串含空格导致匹配失败
   原始数据中类似Machines & production的字符串，用Split拆分后，arr(0)会是"Machines "（末尾带空格），转小写后是"machines "，和你判断用的"machines"完全不匹配，自然触发不了后续逻辑。必须用Trim()清除字符串前后的空格。

2. 多分类判断的笔误
   在处理双分类（带&的情况）时，production的判断语句写错了：

   If LCase(arr(0)) = "production" Or LCase(arr(0)) = "production" Then
   

   两个条件都是判断arr(0)，应该把第二个改为arr(1)。

修正后的代码 #

Sub sortfill()
    ' This sub parses through the vendor list and categorizes the vendors according to type
    Dim mystring As String, arr() As String
    Dim i As Integer
    Dim sourceSheet As Worksheet
    Set sourceSheet = Sheet1
    
    ' 获取最后一行，避免用Select/Activate
    i = sourceSheet.Cells(sourceSheet.Rows.Count, 3).End(xlUp).Row
    
    While i > 1
        mystring = sourceSheet.Cells(i, 3).Value
        arr = Split(mystring, "&")
        
        ' 处理单分类情况
        If UBound(arr) = 0 Then
            Select Case LCase(Trim(arr(0)))
                Case "machines"
                    sourceSheet.Cells(i, 3).CurrentRegion.Copy
                    PasteToSheet Sheet2
                Case "factory"
                    sourceSheet.Cells(i, 3).CurrentRegion.Copy
                    PasteToSheet Sheet4
                Case "production"
                    sourceSheet.Cells(i, 3).CurrentRegion.Copy
                    PasteToSheet Sheet3
            End Select
            
        ' 处理双分类情况
        ElseIf UBound(arr) = 1 Then
            ' 检查是否包含machines
            If LCase(Trim(arr(0))) = "machines" Or LCase(Trim(arr(1))) = "machines" Then
                sourceSheet.Cells(i, 3).CurrentRegion.Copy
                PasteToSheet Sheet2
            End If
            ' 检查是否包含factory
            If LCase(Trim(arr(0))) = "factory" Or LCase(Trim(arr(1))) = "factory" Then
                sourceSheet.Cells(i, 3).CurrentRegion.Copy
                PasteToSheet Sheet4
            End If
            ' 检查是否包含production
            If LCase(Trim(arr(0))) = "production" Or LCase(Trim(arr(1))) = "production" Then
                sourceSheet.Cells(i, 3).CurrentRegion.Copy
                PasteToSheet Sheet3
            End If
        End If
        
        i = i - 1
    Wend
End Sub

' 提取粘贴逻辑为独立子过程，减少重复代码
Sub PasteToSheet(targetSheet As Worksheet)
    With targetSheet
        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
        .Cells(lastRow + 2, 1).PasteSpecial
    End With
End Sub

额外优化说明 #

• 把重复的粘贴逻辑提取成PasteToSheet子过程，减少代码冗余，方便后续维护。
• 去掉了所有Activate和Select，改用工作表对象直接引用，避免因工作表切换导致的错误，同时提升代码运行效率。

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