如何实现A~B的拆封

2427228339

zxsea_7426

ykcbf1100

参与一下。

rakehell78

Sub SplitData()     Dim data As Variant     Dim i As Long, j As Long     Dim str As String          '将数据以换行符为分隔符分割成数组     data = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value          '遍历每一个数据     For i = LBound(data) To UBound(data)         '如果数据包含"~"符号，则拆分成多个子数据         If InStr(data(i, 1), "~") > 0 Then             Dim subData As Variant             subData = Split(data(i, 1), "~") '以"~"符号为分隔符拆分             '将第一个子数据保存             Range("B" & j).Value = Trim(subData(0))             j = j + 1 '增加计数器             '将其余子数据保存             For k = 1 To UBound(subData)                 Range("B" & j).Value = Trim(subData(0)) & Mid(subData(k), InStr(subData(k), "-") + 1, Len(subData(k))) '将第一个子数据和其余子数据的后缀拼接存储                 j = j + 1 '增加计数器             Next k         Else '如果数据不包含"~"符号，则直接保存             Range("B" & j).Value = data(i, 1)             j = j + 1 '增加计数器         End If     Next i End Sub

ZHLK

Sub demo()
a = 2
Range("C2:C10000").ClearContents
For i = 2 To Range("a65320").End(xlUp).Row
    If InStr(Cells(i, 1), "~") Then
        For j = Asc(Mid(Cells(i, 1), InStr(Cells(i, 1), "~") - 1, 1)) To Asc(Mid(Cells(i, 1), InStr(Cells(i, 1), "~") + 1, 1))
            Cells(a, 3) = Left(Cells(i, 1), InStr(Cells(i, 1), "~") - 2) & Chr(j)
            a = a + 1
        Next j
    Else
        Cells(a, 3) = Cells(i, 1)
        a = a + 1
    End If
Next i

End Sub

rakehell78

Sub ykcbf() '//2023.5.29 Dim arr() As Variant Dim lastRow As Long Dim i As Long, j As Long, k As Long Dim s As String, st As String, st1 As String, st2 As String Dim colStart As Long, colEnd As Long, rowNum As Long Dim reg As Object Set reg = CreateObject("VBScript.Regexp") reg.Pattern = "\d+" lastRow = Cells(Rows.Count, "A").End(xlUp).Row ReDim arr(1 To lastRow, 1 To 1) k = 1 For i = 2 To lastRow s = Cells(i, 1) If InStr(s, "") = 0 Then arr(k, 1) = s k = k + 1 Else st = Split(s, "") st1 = Val(st(0)) reg.Pattern = "\d+" st2 = reg.Replace(st(0), "") colStart = Range(st2 & "1").Column st2 = reg.Replace(st(1), "") colEnd = Range(st2 & "1").Column rowNum = Val(Mid(st(0), 1, reg.Execute(st(0))(0).FirstIndex)) For j = colStart To colEnd arr(k, 1) = Cells(rowNum, j).Value & Cells(1, j).Address(False, False) k = k + 1 Next End If Next Range("C2").Resize(k - 1, 1).Value = arr End Sub

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, cr, i&, j&, r&, aMatch As Object
   
    ar = Range("A2", Cells(Rows.Count, "A").End(xlUp))
    ReDim br(1 To UBound(ar) * 26, 0)
   
    With CreateObject("VBScript.RegExp")
        .Pattern = "([0-9]+)([A-Z~]*)"
        For i = 1 To UBound(ar)
            With .Execute(ar(i, 1))(0)
                If .submatches(1) = "" Then
                    r = r + 1
                    br(r, 0) = ar(i, 1)
                Else
                    cr = Split(.submatches(1), "~")
                    For j = Asc(cr(0)) To Asc(cr(UBound(cr)))
                         r = r + 1
                         br(r, 0) = .submatches(0) & Chr(j)
                    Next j
                End If
            End With
        Next i
    End With
   
    [C2:C1000].ClearContents
    [C2].Resize(r) = br
    Beep
End Sub

gwjkkkkk

参与一下。。。