Question

我大约有41188行需要自动调整，以使E列具有不同的值除以'|'需要在新行中添加，每个行仅包含一个值。从A到D以及F到G的数据必须复制到新行中。以下是如何保存数据的示例。
Before

这是应该怎么做

这只是数据的一个示例。在实际文档中，有41188多行需要以相同的方式进行调整，并且E列可能具有不同的值，需要在新行中复制这些值，因此应通过划分的值来动态调整行的创建由运营商| 。

Answer 1

看看此代码是否满足您的要求...

Public Sub TransformData()
    On Error GoTo CleanUp

    Dim objSrcSheet As Worksheet, objDestSheet As Worksheet, lngEndRow As Long
    Dim lngRow As Long, rngToCopy As Range, strColToDelimit As String
    Dim strValueToDelimit As String, lngWriteRow As Long, arrValues, i As Long

    ' Change the below lines to suit your own workbook.
    Set objSrcSheet = Worksheets("Source")
    Set objDestSheet = Worksheets("Transformed")
    strColToDelimit = "E"

    objDestSheet.Cells.Clear

    lngEndRow = objSrcSheet.Cells.SpecialCells(xlCellTypeLastCell).Row

    lngWriteRow = 1

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    For lngRow = 1 To lngEndRow
        Application.StatusBar = "Processing Row " & lngRow & " of " & lngEndRow & " ..."

        If lngRow Mod 500 = 0 Then DoEvents

        Set rngToCopy = objSrcSheet.Rows(lngRow)
        strValueToDelimit = objSrcSheet.Cells(lngRow, strColToDelimit)

        arrValues = Split(strValueToDelimit, "|")

        rngToCopy.Copy objDestSheet.Range("A" & lngWriteRow & ":A" & lngWriteRow + UBound(arrValues))

        For i = 0 To UBound(arrValues)
            objDestSheet.Cells(lngWriteRow, strColToDelimit) = arrValues(i)
            lngWriteRow = lngWriteRow + 1
        Next
    Next

    objDestSheet.Columns.AutoFit
    objDestSheet.Activate

CleanUp:
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    Application.StatusBar = ""
End Sub

...这里最大的测试将是性能，尽管这应该可以工作，但您可能仍想寻求更好的性能解决方案。

您需要将代码添加到VBA编辑器中的新模块中，并更改代码顶部指向源工作表和目标工作表名称的值。配置方式，您需要创建一个名为 Transformed 的工作表，并将带有源数据的工作表的名称设置为 Source ，您可以将其更改为工作簿中工作表的名称。

正在查看E列中的定界值。

只需像以前运行的任何其他宏一样，从开发人员菜单中运行该宏即可。

正在处理时，您会在状态栏中看到它正在更新，以显示已完成的行数和已确定需要执行的行数。

由您决定！还是值得一试。

Answer 2

如果遵循此link，您会发现拆分多值字段非常容易。如果您有这样的数据

转到数据/获取数据/从文件/从工作簿，然后选择包含数据的工作簿

在编辑器中，选择多值列，然后转到 Transform

选择分隔列/按定界符

填写图片中的字段。同时打开高级选项并更改为行

这是编辑器中的结果

转到主页/关闭并加载

然后您将获得一张新工作表，其中的数据将被多值字段分开

Answer 3

由于@skin正确地强调了性能，因此我尝试使用41188行和E列拆分数为6的代码，这在我的旧笔记本电脑上大约需要1-2分钟。在我的方法中，我尝试以数组的方式进行数据处理，然后一次将其复制到新的工作表（可能会更改为您选择的表）中，以使访问excel单元格的次数最少。该代码由代码转置，因为使用WorksheetFunction的转置数组可能有一些limitation。由于我个人习惯避免进行计算，屏幕更新，事件被禁用，因此我在试用中并不习惯将其关闭。它可以用于进一步优化代码。

代码：

Sub test()
tm = Timer
Dim SrcArr As Variant, TrgArr As Variant, LastRow As Long
Dim EcolVal As Variant, itm As Long, NewRw As Long
Dim Ws As Worksheet
Dim i As Long, n As Long

ReDim TrgArr(1 To 7, 0)
LastRow = ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
SrcArr = ThisWorkbook.Sheets("Sheet1").Range("A1:G" & LastRow).Value
NewRw = 0
    For rw = LBound(SrcArr, 1) To UBound(SrcArr, 1)
    EcolVal = Split(SrcArr(rw, 5), "|")

        If UBound(EcolVal) <= 0 Then
        NewRw = NewRw + 1
        ReDim Preserve TrgArr(1 To 7, NewRw)
            For i = 1 To 7
            TrgArr(i, NewRw) = SrcArr(rw, i)
            Next
        Else
            For itm = LBound(EcolVal) To UBound(EcolVal)
            NewRw = NewRw + 1
            ReDim Preserve TrgArr(1 To 7, NewRw)
                For i = 1 To 7
                    If i = 5 Then
                    TrgArr(i, NewRw) = EcolVal(itm)
                    Else
                    TrgArr(i, NewRw) = SrcArr(rw, i)
                    End If
                Next
            Next
        End If
    Next


Dim TrgArr2 As Variant
    ReDim TrgArr2(1 To UBound(TrgArr, 2), 1 To UBound(TrgArr, 1))
    For i = 1 To UBound(TrgArr, 2)
        For n = 1 To UBound(TrgArr, 1)
            TrgArr2(i, n) = TrgArr(n, i)
        Next
    Next

 Set Ws = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
 Ws.Range("A1").Resize(UBound(TrgArr2, 1), UBound(TrgArr2, 2)).Value = TrgArr2
Debug.Print Timer - tm
End Sub

创建一个自动任务以将数据复制到每个excel行的新行中

3 个答案: