VBA分行

原始表格

row_split3()的结果

一列里的每个单元格，数据都是有同一分隔符的，以此列为基础，将数据分为多行。

 1 Sub row_split1()
 2 '要用数组：数据几百行，直接用单元格算可能要十几分钟，数组十几秒。
 3 '一个区域中的一列的每个单元格：字符以sep分隔。
 4 '一个单元格分行后，每个字符对应本行数据不变。
 5 
 6 Dim in_arr() As Variant 'in_arr用来承接原始数据
 7 Dim str_arr() As String '单元格分隔后得到的数组
 8 Dim out_arr() As Variant 'out_arr用来承接分行后的数据
 9 Dim rng As Range
10 Dim rngs As Range
11 Dim rs As Integer, n As Integer, c As Integer
12 Dim col1 As Integer '分裂行在数据的第几列
13 Dim col2 As Integer '分裂行放到数据的第几列
14 Dim cols As Integer '数据列数
15 Dim str_arr_r, in_arr_r, out_arr_r As Integer
16 Dim sep As String
17 Dim mstr As String
18 
19 in_arr = Selection
20 sep = Application.InputBox("请输入分隔符", Default:="、", Type:=2)
21 col1 = Application.InputBox("请输入分行的数据在第几列", Default:="1", Type:=2)
22 
23 mstr = textjoin(sep, True, Range(Selection.Columns(col1).Address))
24  '这里textjoin是自定义函数，有bug，只好写Range(Selection.Columns(col1).Address),2016以后的自带textjoin,应该不用这样
25 rs = Len(mstr) - Len(Application.WorksheetFunction.Substitute(mstr, sep, "")) + 1
26 
27 cols = UBound(in_arr, 2)
28 Set rngs = Selection.Resize(rs, cols)
29 out_arr = rngs 'out_arr用来承接分行后的数据
30 
31 
32 '首先textjoin汇总，substitute剔除分隔符，算出分出多少行，确定out_arr的一维上限ubound(out_arr,1)
33 
34 out_arr_r = LBound(out_arr, 1)
35 
36 Debug.Print out_arr_r
37 
38 For in_arr_r = 1 To UBound(in_arr, 1) '原始数据中循环
39 
40     str_arr = VBA.split(in_arr(in_arr_r, col1), sep)
41     '用split函数，“、”为分隔符，拆分in_arr(in_arr_r, 1)，得到一个数组str_arr
42 
43     For str_arr_r = 0 To UBound(str_arr) '一单元格分为多行
44        For c = 1 To cols
45         out_arr(out_arr_r, c) = in_arr(in_arr_r, c)
46        Next
47    
48         out_arr(out_arr_r, col1) = str_arr(str_arr_r)
49         out_arr_r = out_arr_r + 1 '
50 
51     Next
52 Next
53 Set rng = Application.InputBox("输入数据放置区域", Type:=8)
54 rng.Resize(rs, cols) = out_arr '将数据复制到指定区域
55 
56 End Sub

row_split3()：
规避了部分报错；可以选择chr(10)/chr(13)做分隔符；
可以选择分行结果放置列；
加入了排序，姓名列数据不在团队中，将自动将其加入团队，并位列第一；
比如“张三”不在团队中，运行程序后，进入团队，排序为1；
并复制了原表格的格式

Sub row_split3()

'要用数组：数据几百行，直接用单元格算可能要十几分钟，数组十几秒。
'一个区域中的一列的每个单元格：字符以sep分隔。
'一个单元格分行后，每个字符对应本行数据不变。

Dim in_arr() As Variant 'in_arr用来承接原始数据
Dim str_arr() As String '单元格分隔后得到的数组
Dim out_arr() As Variant 'out_arr用来承接分行后的数据
Dim rng As Range
Dim rngs As Range
Dim rs As Integer, n As Integer, c As Integer
Dim col1 As Integer '分裂行在数据的第几列
Dim col2 As Integer '分裂行放到数据的第几列
Dim cols As Integer '数据列数
Dim str_arr_r, in_arr_r, out_arr_r As Integer
Dim sep As String
Dim mstr As String
On Error GoTo bty
'
    in_arr = Selection '将数据导入数组
    sep = Application.InputBox("请输入分隔符", Default:="、", Type:=2)
    If InStr(1, sep, "chr(10)") Then sep = Chr(10)
    If InStr(1, sep, "chr(13)") Then sep = Chr(13)
    col1 = Application.InputBox("待分行列 在数据的第几列", Default:="1", Type:=1)
    col2 = Application.InputBox("结果放在数据的第几列", Default:=col1, Type:=1)
    cols = UBound(in_arr, 2) + 1
    col3 = Application.InputBox("排序放在第几列", Default:=cols, Type:=1)
     
    Set rng = Application.InputBox("输入数据放置区域", Type:=8)
    
    mstr = textjoin(sep & "", True, Range(Selection.Columns(col1).Address))
     '这里textjoin是自定义函数，有bug，只好写Range(Selection.Columns(col1).Address),2016以后的自带textjoin,应该不用这样
    rs = Len(mstr) - Len(Application.WorksheetFunction.Substitute(mstr, sep & "", "")) + 100 '防止补充数据后，下标越界
    
     
    Set rngs = Selection.Resize(rs, cols)
    out_arr = rngs 'out_arr用来承接分行后的数据
    'out_arr = Selection.Resize(rs, cols)'这样写类型不匹配？
    '首先textjoin汇总，substitute剔除分隔符，算出会分出多少行，也就是out_arr的一维上限是ubound(out_arr,1)
    
    out_arr_r = LBound(out_arr, 1)
    
    For in_arr_r = LBound(in_arr, 1) To UBound(in_arr, 1) '原始数据中循环
        If InStr(1, in_arr(in_arr_r, col1), in_arr(in_arr_r, col2)) = 0 Then in_arr(in_arr_r, col1) = in_arr(in_arr_r, col2) & sep & in_arr(in_arr_r, col1)
        str_arr = VBA.split(in_arr(in_arr_r, col1), sep)
        '用split函数，“、”为分隔符，拆分in_arr(in_arr_r, 1)，得到一个数组str_arr

        For str_arr_r = LBound(str_arr) To UBound(str_arr) '一单元格分为多行
            For c = LBound(in_arr, 2) To UBound(in_arr, 2)
                out_arr(out_arr_r, c) = in_arr(in_arr_r, c)
            Next
        
                out_arr(out_arr_r, col2) = str_arr(str_arr_r)
                out_arr(out_arr_r, col3) = str_arr_r + 1
                out_arr_r = out_arr_r + 1
    
        Next
    Next
    
    rng.Resize(rs, cols) = out_arr '将结果导出制到指定区域
    Selection.Copy'调整格式
    rng.Resize(rs, cols).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
bty:
    Exit Sub


End Sub