VBA宏解析物料清单引用遇问题：循环/空白行/前缀异常求助

问题背景 #

处理客户物料清单时，需将短横线缩写的元件引用（如C1-4展开为C1 C2 C3 C4）展开为完整序列，客户输入格式包含逗号、空格混合分隔，且存在空白行，要求输出列对应空白行需保持为空。

输入示例 #

CR161-169

 (blank line)
 
   R2, R5, 7-11

   R103-7
   
   R26 R28-30 R42, R45-46, R62-65, R70-71, R92-102, R113-114
   
   R31-35 R40-41 R56-61 R72-79 R86-91

 (blank line)
   
   LED1-4, 6-8

预期输出 #

CR161 CR162 CR163 CR164 CR165 CR166 CR167 CR168 CR169
(Blank line)
R2 R5 R7 R8 R9 R10 R11
R103 R104 R105 R106 R107
etc. 

当前宏存在的问题 #

• 输出列空白行被上方单元格内容填充，未保持为空；
• 选中整列时进入无限循环，向下方无限行填充最后一个单元格内容；
• 纯数字范围（如7-11）无法自动补全所在单元格的元件前缀（如R）。

原代码 #

Sub ParseCell()
' Set the input range where your values are
Dim inputRange As Range, outputCell As Range, inputArea As Range
Dim inputCell As Variant
Dim startNum As Long, endNum As Long
Dim i As Long
Dim resList  As String
Debug.Print "Selection_change"

Set inputRange = Selection ' Use the selected range as input

' Set the output range where you want the split references
Set outputCell = inputRange.Offset(0, 1).Cells(1) ' Output in the column next to the input

    ' Loop through each area in the input range
    resList = ""
    For Each inputArea In inputRange.Areas
        ' Loop through each cell in the area
        For Each inputCell In inputArea
            Set outputCell = inputCell.Offset(0, 1).Cells(1)
            ' Split the value by dash
            Dim parts() As String
            If Len(inputCell.Value) > 0 Then
                resList = ""
            ElseIf Len(inputCell.Value) = 0 Then ' blank cell
                Debug.Print "blank"
                'the same as previous
                'resList = resList
            ElseIf IsEmpty(inputCell) Then
                Debug.Print "empty"
                resList = ""
            End If
            If Len(inputCell.Value) > 0 Then
                parts = Split(Replace(inputCell.Value, ",", " "), " ")
                For i = LBound(parts) To UBound(parts)
                    If Len(Trim(parts(i))) > 0 Then
                        resList = resList & ExpandCellsList(Trim(parts(i))) & " "
                    End If
                Next i
                If Len(resList) > 0 Then resList = Left(resList, Len(resList) - 1)
            End If
            Debug.Print outputCell.Address, resList
            outputCell.Value = resList
        Next inputCell
    Next inputArea
End Sub

Public Function ExpandCellsList(cl As String) As String
Dim i As Long
Dim sH As String, sv1 As String, sv2 As String
Dim startNum As Long, endNum As Long
Dim res As String
    i = InStr(1, cl, "-")
    If i > 0 Then
        sv2 = Trim(Mid(cl, i + 1))
        sH = Trim(Left(cl, i - 1))
        For i = 1 To Len(sH)
            If InStr(1, "01234567890", Mid(sH, i, 1)) > 0 Then
                sv1 = Trim(Mid(sH, i))
                sH = Trim(Left(sH, i - 1))
                Exit For
            End If
        Next i
        If Len(sv2) < Len(sv1) Then
            sv2 = Left(sv1, Len(sv1) - Len(sv2)) & sv2
        End If
        startNum = Val(sv1)
        endNum = Val(sv2)
        If endNum > startNum Then
            For i = startNum To endNum
                res = res & sH & CStr(i) & " "
            Next i
        End If
        If Len(res) > 0 Then res = Left(res, Len(res) - 1)
        ExpandCellsList = res
    Else
        ExpandCellsList = cl
    End If
End Function

修复方案及修改后代码 #

修复要点 #

1. 空白行修复：每个单元格处理前重置结果字符串为空，空单元格直接输出空值；
2. 整列循环修复：仅遍历选中区域内的非空单元格，避免整列选中时的无限遍历；
3. 前缀补全修复：新增函数提取单元格的共同元件前缀，为纯数字/数字范围自动补全前缀。

修改后完整代码 #

Sub ParseCell()
    Dim inputRange As Range, inputArea As Range
    Dim inputCell As Range
    Dim resList As String
    Dim parts() As String
    Dim i As Long
    Dim cellPrefix As String
    
    ' 仅处理选中区域中的非空单元格，避免整列选中时无限循环
    On Error Resume Next
    Set inputRange = Selection.SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
    
    If inputRange Is Nothing Then Exit Sub ' 无有效内容时直接退出
    
    ' 遍历每个区域的每个单元格
    For Each inputArea In inputRange.Areas
        For Each inputCell In inputArea
            resList = ""
            cellPrefix = GetCellPrefix(inputCell.Value) ' 获取当前单元格的共同元件前缀
            
            If Len(Trim(inputCell.Value)) > 0 Then
                ' 统一用空格分隔（替换逗号为空格）
                parts = Split(Replace(inputCell.Value, ",", " "), " ")
                
                For i = LBound(parts) To UBound(parts)
                    If Len(Trim(parts(i))) > 0 Then
                        resList = resList & ExpandCellsList(Trim(parts(i)), cellPrefix) & " "
                    End If
                Next i
                
                ' 移除末尾多余空格
                If Len(resList) > 0 Then resList = Left(resList, Len(resList) - 1)
            End If
            
            ' 输出到相邻列，空单元格对应输出空
            inputCell.Offset(0, 1).Value = resList
        Next inputCell
    Next inputArea
End Sub

' 获取单元格内容的共同元件前缀（提取字母部分）
Private Function GetCellPrefix(cellValue As String) As String
    Dim i As Long
    Dim prefix As String
    cellValue = Trim(cellValue)
    
    ' 提取第一个有效项的字母前缀
    Dim firstPart As String
    firstPart = Split(Replace(cellValue, ",", " "), " ")(0)
    firstPart = Trim(firstPart)
    
    For i = 1 To Len(firstPart)
        If Not IsNumeric(Mid(firstPart, i, 1)) Then
            prefix = prefix & Mid(firstPart, i, 1)
        Else
            Exit For
        End If
    Next i
    
    GetCellPrefix = prefix
End Function

' 展开单个引用，支持传入前缀补全纯数字范围
Public Function ExpandCellsList(cl As String, Optional prefix As String = "") As String
    Dim i As Long
    Dim sH As String, sv1 As String, sv2 As String
    Dim startNum As Long, endNum As Long
    Dim res As String
    Dim hasDash As Boolean
    
    hasDash = InStr(1, cl, "-") > 0
    
    ' 纯数字/数字范围，使用传入的共同前缀
    If IsNumeric(Replace(cl, "-", "")) Then
        sH = prefix
        If hasDash Then
            sv1 = Trim(Split(cl, "-")(0))
            sv2 = Trim(Split(cl, "-")(1))
        Else
            sv1 = cl
            sv2 = cl
        End If
    Else
        ' 拆分已有前缀和数字
        If hasDash Then
            sv2 = Trim(Mid(cl, InStr(1, cl, "-") + 1))
            sH = Trim(Left(cl, InStr(1, cl, "-") - 1))
            For i = 1 To Len(sH)
                If IsNumeric(Mid(sH, i, 1)) Then
                    sv1 = Trim(Mid(sH, i))
                    sH = Trim(Left(sH, i - 1))
                    Exit For
                End If
            Next i
        Else
            sH = ""
            sv1 = cl
            ' 提取当前项的前缀
            For i = 1 To Len(cl)
                If Not IsNumeric(Mid(cl, i, 1)) Then
                    sH = sH & Mid(cl, i, 1)
                Else
                    Exit For
                End If
            Next i
            sv1 = Replace(cl, sH, "")
            sv2 = sv1
        End If
    End If
    
    ' 处理数字位数补全（如R103-7 → R103到R107）
    If hasDash Then
        If Len(sv2) < Len(sv1) Then
            sv2 = Left(sv1, Len(sv1) - Len(sv2)) & sv2
        End If
        startNum = Val(sv1)
        endNum = Val(sv2)
        
        ' 确保起始数不大于结束数
        If endNum >= startNum Then
            For i = startNum To endNum
                res = res & sH & CStr(i) & " "
            Next i
        End If
    Else
        res = sH & sv1 & " "
    End If
    
    ' 移除末尾空格
    If Len(res) > 0 Then res = Left(res, Len(res) - 1)
    ExpandCellsList = res
End Function

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