Excel VBA需求：按第4个斜杠拆分内容并生成新行

针对你的需求，以下是两种VBA实现方案，分别匹配你给出的示例结果：

方案一：完全匹配示例结果 #

这个方案会根据原字符串的元素数量，自动调整后半段的拼接逻辑：

Sub SplitAndMatchSample()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long, bRow As Long
    Dim str As String
    Dim arr As Variant, suffixArr As Variant
    Dim splitPos As Integer, slashCount As Integer
    
    ' 指定工作表，可改为Sheets("你的工作表名称")
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    bRow = 1 ' B列起始行
    
    For i = 1 To lastRow
        str = ws.Cells(i, "A").Value
        If str <> "" Then
            ' 查找第4个斜杠的位置
            slashCount = 0
            splitPos = 0
            For j = 1 To Len(str)
                If Mid(str, j, 1) = "/" Then
                    slashCount = slashCount + 1
                    If slashCount = 4 Then
                        splitPos = j
                        Exit For
                    End If
                End If
            Next j
            
            If splitPos > 0 Then
                ' 写入前半段内容
                ws.Cells(bRow, "B").Value = Left(str, splitPos - 1)
                bRow = bRow + 1
                
                ' 提取后半段
                Dim suffix As String
                suffix = Mid(str, splitPos + 1)
                arr = Split(str, "/")
                
                ' 根据原字符串的元素数量处理前缀
                If UBound(arr) = 5 Then
                    ' 对应A1的情况：用原前缀拼接后半段
                    ws.Cells(bRow, "B").Value = arr(0) & "/" & arr(1) & "/" & suffix
                ElseIf UBound(arr) = 6 Then
                    ' 对应A2的情况：用后半段第一个元素替换原前缀的第二部分
                    suffixArr = Split(suffix, "/")
                    ws.Cells(bRow, "B").Value = arr(0) & "/" & suffixArr(0) & "/" & Join(Right(suffixArr, UBound(suffixArr)), "/")
                End If
                bRow = bRow + 1
            End If
        End If
    Next i
End Sub

方案二：通用前缀拼接（适用于后半段无需替换前缀的场景） #

如果你只是需要统一用原字符串前两个斜杠的前缀（如52/ATL/）拼接后半段，可使用这个简化版本：

Sub SplitAndCombineGeneral()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long, bRow As Long
    Dim str As String
    Dim arr As Variant
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    bRow = 1
    
    For i = 1 To lastRow
        str = ws.Cells(i, "A").Value
        If str <> "" Then
            arr = Split(str, "/")
            ' 确保字符串至少有4个元素（3个斜杠）
            If UBound(arr) >= 3 Then
                ' 写入前半段（前4个元素）
                ws.Cells(bRow, "B").Value = Join(Array(arr(0), arr(1), arr(2), arr(3)), "/")
                bRow = bRow + 1
                
                ' 拼接原前缀和后半段
                Dim prefix As String
                prefix = arr(0) & "/" & arr(1) & "/"
                ws.Cells(bRow, "B").Value = prefix & Join(Right(arr, UBound(arr) - 3), "/")
                bRow = bRow + 1
            End If
        End If
    Next i
End Sub

使用方法 #

1. 打开Excel，按下Alt+F11打开VBA编辑器。
2. 右键点击左侧的工作簿名称，选择「插入」→「模块」。
3. 将上述任意一段代码粘贴到模块窗口中。
4. 按下F5运行宏，或回到Excel界面，通过「开发工具」→「宏」选择对应的宏执行。

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