求一段VBA语言可以将一个单元格的内容分成多行记录

Question

如题所述

Answer 1

Sub splitting()
startRow = 3 '已知你的表里面待拆分数据是从第三行开始的。
endrow = ActiveSheet.Range("A65535").End(xlUp).Row 'A列从第65535行开始倒数，直到不为空（这样找出A列最下一行有数据的）
 i = startRow

rowx = 1
Do While i <= endrow 'A列从第三行开始用循环遍历
     nameQty = UBound(Split(Cells(i, 2), "；", , vbTextCompare)) + 1 '以分号作为拆分符，拆当前行的第二列，得到拆出的字段数
     For j = 1 To nameQty '遍历拆出来的字段
     Cells(rowx + 2, 5).Value = Split(Cells(i, 2), "；", , vbTextCompare)(j - 1)
       Cells(rowx + 2, 4).Value = Cells(i, 1).Value
     rowx = rowx + 1
     Next
     rowx = rowx - 1
    
i = i + 1

Loop
End Sub

追问

其实我在查到一条差不多的vba，可不可以在这个的版本上面添加一下？



追答

循环是一样的，只是我用了do loop 和for next两种。

里面取值我用了变量，他是逐条写，所以他的看起来行数多些。

拆分的最后一列，因为例题不同，先前你给的有分号，必须用split，后来你给的是选择题1234，不存在12,34这样的可能，所以没有间隔符号，可以直接用left ,right, mid取数。

怎么改都行的，其他没有技术差异了。

 

如果你是在做问卷调查的话，用excel太罗嗦了。我有更好的online survey。 浏览器访问服务器上的问卷，宣布做完的瞬间，随时可以看统计图表。





Answer 2

你好，此问题可以通过Excel VBA完美解决。详见 简书的文章《用ExcelVBA实现自动拆分单元格中的内容到多行中》网页链接。全部VBA代码如下，复制粘贴到你的Excel中就可以。

Sub ChaiFenDanYuanGe()'声明变量
Dim arr() As String '定义一个字符串数组，用来存放单元格拆分后的数据
Dim m%              '定义一个整数，用来记录单元格内容需拆分的总行数
Dim n%              '定义一个整数，用来记录要拆分单元格的总个数
Dim row1, col1      '记录所选单元格所在的行数 和 列数
Dim i%, j%          '循环计数变量
Dim max%            '记录最大整数

'第1步，把拆分的数据存放到数组arr里    '第1.1步，确定要拆多少行，即确定m的值
        '第1.1.1步，选择区域有几列？也就是要拆分的单元格的总个数，即n的值        '注意：我们选择的区域都是1行1列 或 1行多列
        n = Selection.Count
    If n = 1 Then   '如果选择区域仅有一个单元格，那么...
        m = UBound(VBA.Split(Selection.Cells(1, n), Chr(10)))    Else            '如果选择区域不止一个单元格，那么通过比较，确定出选中区域，单元格能拆分的最多行数
        m = UBound(VBA.Split(Selection.Cells(1, 1), Chr(10)))
        For i = 2 To n
            max = UBound(VBA.Split(Selection.Cells(1, i), Chr(10)))
            If max > m Then
                m = max
            End If
        Next i
    End If
    
    '第1.2步，存数据到数组，    'split分隔符是chr(10)，也就是单元格里的alt+enter这种回车
    '如果要用其他的分隔符，如用分号分隔，则直接split(单元格，"；")即可
    ReDim arr((n - 1), m) '数组arr()是m+1行，n列
    For i = 0 To (n - 1)
        '获取单元格split后的字符串个数，防止下标j越界
        max = UBound(Application.Transpose(Application.Transpose(VBA.Split(Selection.Cells(1, i + 1), Chr(10))))) - 1
        For j = 0 To m            If j <= max Then
                arr(i, j) = Application.Transpose(Application.Transpose(VBA.Split(Selection.Cells(1, i + 1), Chr(10))))(j + 1)
            End If
        Next j
    Next i'第2步，在所选区域上方，插入m行，并且复制所选区域的内容
    '第2.1步，获取activecell所在的行数，selection第一个单元格的列数
    row1 = ActiveCell.Row
    col1 = Selection.Cells(1, 1).Column    '第2.2步，插入m行
    For i = 1 To m
        Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
    Next i
    '第2.3步，复制行
    Cells(row1 + m, 1).EntireRow.Copy
    Range(Cells(row1, 1), Cells(row1 + m - 1, 1)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False'第3步，将数组arr中的数据覆盖拆分区域
For i = 0 To n - 1
    For j = 0 To m
        Cells(row1 + j, col1 + i) = arr(i, j)
    Next j
Next i
'大功告成，将焦点放在A1单元格
Cells(1, 1).Select
End Sub

Answer 3

用函数行否？追问

因为我处理的数据比较多而且杂乱，用VBA会比较好一点，不过也谢谢你提出这个建议。不知道能用什么函数呢？

追答

需要用辅助列实现，权当交流学习下！