字符串转移

Amway@2022

如上图，A列信息，用\ ; ；/等符号分隔了（空格忽略）。
我想将A列信息内容，根据B列序的顺序填写到E列中。
英文字母区分，小写转大写；字符串中的空格去掉；
第3行的3个字符串要填写到5个序号的信息列中，则按信息的顺序循环填写
填写结果如下图：


请教老师，如何通过vba实现

Qs18

Sub qs()
Dim arr, i
Set dic = CreateObject("scripting.dictionary")
bb = [{"\",";","；","/"}]
arr = Sheet1.Range("a1").CurrentRegion.Value
For i = 2 To UBound(arr)
    arr(i, 1) = VBA.Replace(arr(i, 1), " ", "")
    arr(i, 1) = VBA.Replace(arr(i, 1), "q", "Q")
    For Each b In bb
        arr(i, 1) = Replace(arr(i, 1), b, "/")
    Next
Next
For i = 2 To UBound(arr)
    ss = Split(arr(i, 1), "/")
    tt = Split(arr(i, 2), "/")
    If UBound(ss) = UBound(tt) Then
    For j = LBound(tt) To UBound(tt)
        dic(tt(j)) = ss(j)
    Next
    ElseIf UBound(tt) > UBound(ss) Then
        x = 0
        For m = LBound(tt) To UBound(tt)
            
            dic(tt(m)) = ss(x)
            x = x + 1
            If x > UBound(ss) Then x = 0
        Next
    End If
Next
cr = Sheet1.Range("d1").CurrentRegion.Value
For i = 2 To UBound(cr)
    cr(i, 2) = dic(CStr(cr(i, 1)))
Next
Sheet1.Range("g1").Resize(UBound(cr), 2) = cr
End Sub

Qs18

试试.........

Qs18

试试..........

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    arr = Sheet1.[a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    Set dic = CreateObject("scripting.dictionary")
    br = Split("\ ; ； /")          '请注意，每个字符之间有个空格，这个根据实际情况添加减少。
    For i = 0 To UBound(br)
        d(br(i)) = ""
    Next
    For i = 2 To UBound(arr)
        For Each k In d.keys
            If InStr(arr(i, 1), k) Then arr(i, 1) = Replace(arr(i, 1), k, "/")
        Next
        crr = Split(arr(i, 1), "/")
        drr = Split(arr(i, 2), "/")
        If UBound(crr) < UBound(drr) Then
            n = 0
            For j = 0 To UBound(drr)
                If j <= UBound(crr) Then
                    dic(1 * drr(j)) = UCase(Replace(crr(j), " ", ""))
                Else
                    dic(1 * drr(j)) = UCase(Replace(crr(n), " ", "")): n = n + 1
                End If
            Next
        Else
            For j = 0 To UBound(drr)
                dic(1 * drr(j)) = UCase(Replace(crr(j), " ", ""))
            Next
        End If
    Next
    Key = dic.keys
    Item = dic.items
    For i = 0 To UBound(Key) - 1
        For j = i + 1 To UBound(Key)
            If Key(i) > Key(j) Then
                tmp = Key(i)
                Key(i) = Key(j)
                Key(j) = tmp
                tmp = Item(i)
                Item(i) = Item(j)
                Item(j) = tmp
            End If
        Next
    Next
    Sheet1.[g1:h1] = [{"序","信息"}]
    Sheet1.[g2].Resize(dic.Count) = Application.Transpose(Key)
    Sheet1.[h2].Resize(dic.Count) = Application.Transpose(Item)
    Set d = Nothing
    Set dic = Nothing
    Beep
End Sub

cnmlgb9998

用PQ解决。借楼练一下PQ


是这个效果吗？

cidanji