VBA自定义含'-'文件名提取规则：保留指定内容避免截断

针对你当前代码截断所有“-”后内容的问题，以下提供两种可自定义规则的修改方案，适配你需要保留部分“-”后内容的需求：

方案1：按关键词/规则保留特定“-”后内容 #

此方案允许你通过设置关键词或判断条件，决定哪些“-”后的内容需要保留，哪些需要截断：

Sub GetFileNameCustom()
    Dim lr As Long
    Dim Rng As Range
    Dim arr1() As String
    Dim arr2() As String
    Dim fileNamePart As String
    Dim parts() As String
    Dim i As Integer
    Dim keepParts As String
    ' 自定义例外关键词：需要保留的"-"后内容关键词（可按需增删）
    Dim keepKeywords As Variant
    keepKeywords = Array("Pro", "Max", "Plus", "12", "13", "14")
    
    Application.ScreenUpdating = False
    Sheets("Master").Select
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    Columns("C:C").NumberFormat = "@"
    
    For Each Rng In Range("A2:A" & lr)
        arr1 = Split(Rng.Value, "\")
        ' 提取完整文件名到B列
        Rng.Offset(0, 1).Value = arr1(UBound(arr1, 1))
        ' 提取括号前的部分并移除.jpg后缀
        arr2 = Split(arr1(UBound(arr1, 1)), "(")
        fileNamePart = Replace(arr2(0), ".jpg", "")
        
        parts = Split(fileNamePart, "-")
        keepParts = parts(0) ' 初始化保留第一段
        
        ' 遍历后续分段判断是否保留
        If UBound(parts) > 0 Then
            For i = 1 To UBound(parts)
                Dim isKeep As Boolean
                isKeep = False
                ' 检查是否在例外关键词列表中
                For Each key In keepKeywords
                    If InStr(1, parts(i), key, vbTextCompare) > 0 Then
                        isKeep = True
                        Exit For
                    End If
                Next key
                ' 额外规则：纯数字分段也保留（比如型号数字）
                If IsNumeric(parts(i)) Then
                    isKeep = True
                End If
                
                ' 符合规则则追加，否则截断后续内容
                If isKeep Then
                    keepParts = keepParts & "-" & parts(i)
                Else
                    Exit For
                End If
            Next i
        End If
        
        ' 处理文件名以"-"开头的特殊情况
        If Left(fileNamePart, 1) = "-" Then
            Rng.Offset(0, 2).Value = fileNamePart
        Else
            Rng.Offset(0, 2).Value = keepParts
        End If
    Next Rng
    Application.ScreenUpdating = True
End Sub

自定义方法： #

• 修改关键词列表：在keepKeywords = Array(...)中添加或删除需要保留的关键词，比如要保留“Mini”，就改成Array("Pro", "Max", "Plus", "Mini", "12", "13", "14")。
• 添加判断规则：如果需要新增保留条件（比如保留包含“XL”的分段），可以在isKeep判断部分添加：If InStr(1, parts(i), "XL", vbTextCompare) > 0 Then isKeep = True。

方案2：保留前N个“-”分割的分段 #

如果你的需求是固定保留前N段（比如保留“品牌-型号”两段，截断后续附加内容），可以使用此简化方案：

Sub GetFileNameKeepFirstTwoParts()
    Dim lr As Long
    Dim Rng As Range
    Dim arr1() As String
    Dim arr2() As String
    Dim fileNamePart As String
    Dim parts() As String
    
    Application.ScreenUpdating = False
    Sheets("Master").Select
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    Columns("C:C").NumberFormat = "@"
    
    For Each Rng In Range("A2:A" & lr)
        arr1 = Split(Rng.Value, "\")
        Rng.Offset(0, 1).Value = arr1(UBound(arr1, 1))
        arr2 = Split(arr1(UBound(arr1, 1)), "(")
        fileNamePart = Replace(arr2(0), ".jpg", "")
        
        parts = Split(fileNamePart, "-")
        If Left(fileNamePart, 1) = "-" Then
            Rng.Offset(0, 2).Value = fileNamePart
        Else
            Select Case UBound(parts)
                Case 0 ' 无"-"，直接保留完整内容
                    Rng.Offset(0, 2).Value = fileNamePart
                Case 1 ' 仅一个"-"，保留全部内容
                    Rng.Offset(0, 2).Value = fileNamePart
                Case Else ' 多个"-"，保留前2段
                    Rng.Offset(0, 2).Value = parts(0) & "-" & parts(1)
            End Select
        End If
    Next Rng
    Application.ScreenUpdating = True
End Sub

自定义方法： #

如果需要保留前3段，只需修改Case Else部分的代码为：

Rng.Offset(0, 2).Value = parts(0) & "-" & parts(1) & "-" & parts(2)

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