如何把A列的数据转换成D\E列的格式？谢谢！

szqhb

chis3

Sub test()
    Dim arr, dic As Object, i As Byte, j As Byte, brr(1 To 10000, 1 To 2), k As Byte
    Set dic = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
        dic(Split(arr(i, 1), "：")(0)) = Split(arr(i, 1), "：")(1)
        On Error Resume Next
        For j = 0 To 255
            k = k + 1
            brr(k, 2) = dic.keys()(i - 2)
            brr(k, 1) = Split(dic(Split(arr(i, 1), "：")(0)), "、")(j)
            If Err.Number > 0 Then k = k - 1: Exit For
        Next j
        Err.Clear
    Next i
    [d2].Resize(k, 2) = brr
    Set dic = Nothing
End Sub

szqhb

chis3 发表于 2018-7-15 22:45
Sub test()
    Dim arr, dic As Object, i As Byte, j As Byte, brr(1 To 10000, 1 To 2), k As Byte
   ...

谢谢“chis3”，完美！

ww87725244

1. Sub aa()
   
2. Dim ar, i&, ar1, k&, ar2(), m&, n%
   
3. n = Application.InputBox("请输入姓名中需要间隔的空格数量：", "输入", , , , , , 1)
   
4. With Sheet1
   
5.     ar = .[a2:a4]
   
6.     m = 1
   
7.     For i = 1 To UBound(ar)
   
8.         ar1 = Split(Split(ar(i, 1), "：")(1), "、")
   
9.         For k = 0 To UBound(ar1)
   
10.             m = m + 1
    
11.             ReDim Preserve ar2(1 To 2, 1 To m)
    
12.                 ar2(1, 1) = "姓名"
    
13.                 ar2(2, 1) = "班级"
    
14.                 ar2(2, m) = Split(ar(i, 1), "：")(0)
    
15.                 If Len(Trim(ar1(k))) = 2 Then
    
16.                     ar2(1, m) = Application.WorksheetFunction.Replace(ar1(k), 2, 0, Application.Rept(" ", n))
    
17.                 Else
    
18.                     ar2(1, m) = ar1(k)
    
19.                 End If
    
20.         Next
    
21.     Next
    
22.     .[j1].Resize(UBound(ar2, 2), UBound(ar2, 1)) = Application.Transpose(ar2)
    
23. End With
    
24. End Sub
    

复制代码

chis3

szqhb 发表于 2018-7-15 22:58
谢谢“chis3”，完美！

還沒有
沒看到要兩字加空格
這樣
Sub test()
    Dim arr, dic As Object, i As Byte, j As Byte, brr(1 To 10000, 1 To 2), k As Byte
    Set dic = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
        dic(Split(arr(i, 1), "：")(0)) = Split(arr(i, 1), "：")(1)
        On Error Resume Next
        For j = 0 To 255
            k = k + 1
            brr(k, 2) = dic.keys()(i - 2)
            If Len(Split(dic(Split(arr(i, 1), "：")(0)), "、")(j)) = 2 Then
                brr(k, 1) = Left(Split(dic(Split(arr(i, 1), "：")(0)), "、")(j), 1) & "  " & Right(Split(dic(Split(arr(i, 1), "：")(0)), "、")(j), 1)
            Else
                brr(k, 1) = Split(dic(Split(arr(i, 1), "：")(0)), "、")(j)
            End If
            If Err.Number > 0 Then k = k - 1: Exit For
        Next j
        Err.Clear
    Next i
    [d2].Resize(k, 2) = brr
    Set dic = Nothing
End Sub

chis3

szqhb 发表于 2018-7-15 22:58
谢谢“chis3”，完美！

還沒有
沒看到要空格

Sub test()
    Dim arr, dic As Object, i As Byte, j As Byte, brr(1 To 10000, 1 To 2), k As Byte
    Set dic = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
        dic(Split(arr(i, 1), "：")(0)) = Split(arr(i, 1), "：")(1)
        On Error Resume Next
        For j = 0 To 255
            k = k + 1
            brr(k, 2) = dic.keys()(i - 2)
            If Len(Split(dic(Split(arr(i, 1), "：")(0)), "、")(j)) = 2 Then
                brr(k, 1) = Left(Split(dic(Split(arr(i, 1), "：")(0)), "、")(j), 1) & "  " & Right(Split(dic(Split(arr(i, 1), "：")(0)), "、")(j), 1)
            Else
                brr(k, 1) = Split(dic(Split(arr(i, 1), "：")(0)), "、")(j)
            End If
            If Err.Number > 0 Then k = k - 1: Exit For
        Next j
        Err.Clear
    Next i
    [d2].Resize(k, 2) = brr
    Set dic = Nothing
End Sub

szqhb

非常感谢楼上两位！

szqhb

ww87725244 发表于 2018-7-15 23:01

这个代码，年级不同数量的班级需要修改取数范围，能否改成自动，而不管他有几个班

jiminyanyan

chis3 发表于 2018-7-15 23:03
還沒有
沒看到要兩字加空格
這樣

好像可以不用字典。。。

jiminyanyan

szqhb 发表于 2018-7-18 17:56
这个代码，年级不同数量的班级需要修改取数范围，能否改成自动，而不管他有几个班

没看明白，举个例子。。