任意多列数据拆分为多行~~~

coby001

原题在这里：http://club.excelhome.net/thread-1175180-1-2.html

由于此算法是通用的，也可以用于其它的数据，所以开新贴。
由于要尽量保留原数据的的信息，没有对“空”数据进行处理，后期可以通过排序轻易地排除掉空数据。

SplitData.rar (17.56 KB, 下载次数: 72)

2014-12-26 12:36 上传

点击文件名下载附件

coby001

Sub SplitData()
    Const sSep$ = ","    ' 分隔符，可以改为其它字符
    Dim vArrData, vArrRslt(), vArrSnglRow, iC&, iR&, sArr$(), i&, iCol&
    Dim iSnglRows&, iRows&, iCols&, iSR&, iSRTmp&, iSC&
    With Me.[a1].CurrentRegion
        vArrData = Range(Me.[a2], .Cells(.Count))
    End With
    iRows = UBound(vArrData, 1)
    iCols = UBound(vArrData, 2)
    ReDim vArrSnglRow(1 To iCols, 1 To 1)
    For iR = 1 To iRows    ' Row
        iSnglRows = 1
        For iCol = 1 To iCols
            vArrSnglRow(iCol, 1) = Split(vArrData(iR, iCol), sSep)    ' 复制一行数据
            iSnglRows = iSnglRows * (UBound(vArrSnglRow(iCol, 1)) + 1)
        Next    'iCol
        If ((Not vArrRslt) = -1) Then    ' 空数组？
            iSR = 1
            ReDim vArrRslt(1 To iCols, 1 To iSnglRows)
        Else
            iSR = UBound(vArrRslt, 2) + 1
            ReDim Preserve vArrRslt(1 To iCols, 1 To UBound(vArrRslt, 2) + iSnglRows)
        End If
        For iCol = 1 To iCols
            sArr = vArrSnglRow(iCol, 1)
            iSRTmp = iSR
            For i = 0 To UBound(sArr)
                For iSC = iSRTmp To (iSRTmp + iSnglRows - (UBound(sArr) + 1)) Step (UBound(sArr) + 1)
                    vArrRslt(iCol, iSC) = sArr(i)
                Next    'iSC
                iSRTmp = iSRTmp + 1
            Next    'i
        Next    'iCol
    Next    'iR
    vArrRslt = WorksheetFunction.Transpose(vArrRslt)
    With ThisWorkbook.Worksheets("sheet2")
        .UsedRange.Offset(1).Clear
        .[a2].Resize(UBound(vArrRslt, 1), UBound(vArrRslt, 2)) = vArrRslt
        .Activate
    End With
End Sub

关于  空数组 的判断，请看此帖：
http://club.excelhome.net/thread-1158168-1-1.html
vba中判断〇维数组的简便方法

peiyun1982

多谢你的帖子。可是很多行的意思我完全看不懂。所以也就难以融会贯通并举一反三。
请问哪里可以查到这些命令所代表的意思啊？很多命令我都百度不到。
或者您能不能帮忙加上注释。写一下命令的意思。

coby001

peiyun1982 发表于 2014-12-27 10:51
多谢你的帖子。可是很多行的意思我完全看不懂。所以也就难以融会贯通并举一反三。
请问哪里可以查到这些命 ...

无论你有多少列数据需要拆分，这算法都能拆，不止3列。
所以，不需要你举一反三了~

lsxhn

来向高手学习的！！！

selen

Sub SplitData()
    Const sSep$ = "," ' 分隔符，可以改为其它字符
    Dim vArrData, vArrRslt(), vArrSnglRow, iC&, iR&, sArr$(), i&, iCol&
    Dim iSnglRows&, iRows&, iCols&, iSR&, iSRTmp&, iSC&
   
    ' 获取当前工作表的数据区域，并将数据存入数组中
    With Me.[a1].CurrentRegion
        vArrData = Range(Me.[a2], .Cells(.Count))
    End With
   
    ' 计算数据的行数和列数
    iRows = UBound(vArrData, 1)
    iCols = UBound(vArrData, 2)
   
    ' 定义一个空的一维数组
    ReDim vArrSnglRow(1 To iCols, 1 To 1)
   
    For iR = 1 To iRows    ' 遍历每一行
        iSnglRows = 1
        
        ' 将当前行的每一个单元格按照分隔符拆分成多个子串，存储到一维数组vArrSnglRow中
        For iCol = 1 To iCols
            vArrSnglRow(iCol, 1) = Split(vArrData(iR, iCol), sSep)
            
            ' 计算一维数组vArrSnglRow中元素的总数，即新数组的行数
            iSnglRows = iSnglRows * (UBound(vArrSnglRow(iCol, 1)) + 1)
        Next    'iCol
        
        If ((Not vArrRslt) = -1) Then    ' 判断是否是空数组
            iSR = 1
            ReDim vArrRslt(1 To iCols, 1 To iSnglRows)
        Else
            ' 不是空数组，计算新数组的起始行数和总行数，并将原数组扩展为新数组大小
            iSR = UBound(vArrRslt, 2) + 1
            ReDim Preserve vArrRslt(1 To iCols, 1 To UBound(vArrRslt, 2) + iSnglRows)
        End If
        
        ' 将每一行的单元格子串按照笛卡尔积合并成一维数组，并存入新数组中
        For iCol = 1 To iCols
            sArr = vArrSnglRow(iCol, 1)
            iSRTmp = iSR
            
            For i = 0 To UBound(sArr)
                For iSC = iSRTmp To (iSRTmp + iSnglRows - (UBound(sArr) + 1)) Step (UBound(sArr) + 1)
                    vArrRslt(iCol, iSC) = sArr(i)
                Next    'iSC
               
                iSRTmp = iSRTmp + 1
            Next    'i
        Next    'iCol
        
    Next    'iR
   
    ' 将新数组转置
    vArrRslt = WorksheetFunction.Transpose(vArrRslt)
   
    ' 将新数组写入sheet2工作表，清除当前数据区域中的内容
    With ThisWorkbook.Worksheets("sheet2")
        .UsedRange.Offset(1).Clear
        .[a2].Resize(UBound(vArrRslt, 1), UBound(vArrRslt, 2)) = vArrRslt
        .Activate
    End With
End Sub
这个 VBA 子过程的作用是将当前工作表中的每一行按照分隔符分割成多个单元格，并将拆分后的结果重新排列生成一个新的二维数组，并将该数组写入到另一个工作表中。