20170501xlVBA销售订单整理一行转多行

Sub NextSeven_CodeFrame()

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    Application.Calculation = xlCalculationManual

    Application.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>"

    On Error GoTo ErrHandler

    Dim StartTime, UsedTime As Variant

    StartTime = VBA.Timer

    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    Dim Wb As Workbook

    Dim Sht As Worksheet

    Dim oSht As Worksheet

    Dim Rng As Range

    'Dim Arr As Variant

Dim Arr()

    Dim EndRow As Long

    Const HEAD_ROW As Long = 1

    Const SHEET_NAME As String = "原始订单"

    Const START_COLUMN As String = "A"

    Const END_COLUMN As String = "O"

    Dim i As Long, j As Long, k As Long

    Dim N As Long

    Const OTHER_HEAD_ROW As Long = 1

    Const OTHER_SHEET_NAME As String = "整理订单"

    Const OTHER_START_COLUMN As String = "A"

    Const OTHER_END_COLUMN As String = "O"

    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    '获取原始记录

    Set Wb = Application.ThisWorkbook

    Set Sht = Wb.Worksheets(SHEET_NAME)

    With Sht

        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row

        Set Rng = .Range(.Cells(HEAD_ROW + 1, START_COLUMN), .Cells(EndRow, END_COLUMN))

        'Arr = Rng.Value

        ReDim Arr(1 To Rng.Rows.Count, 1 To Rng.Columns.Count)

        With Rng

            For i = 1 To .Rows.Count

                  For j = 1 To .Columns.Count

                        Arr(i, j) = .Cells(i, j).Text

                  Next j

            Next i

        End With

    End With

    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    '生成新记录

    Dim brr() As String

    ReDim brr(1 To 15, 1 To 1)

    N = 0

    For i = LBound(Arr) To UBound(Arr)

        Key = CStr(Arr(i, 2))

        '判断Chr(10)

        If InStr(1, Key, Chr(10)) = 0 Then

            N = N + 1

            ReDim Preserve brr(1 To 15, 1 To N)

            For j = 1 To 15

                brr(j, N) = Arr(i, j)

            Next j

        Else

            crr = Split(Key, Chr(10))

            For k = LBound(crr) To UBound(crr)

                N = N + 1

                ReDim Preserve brr(1 To 15, 1 To N)

                If k = 0 Then

                    For j = 1 To 15

                        If j = 2 Then

                            brr(j, N) = crr(k)

                        Else

                            brr(j, N) = Arr(i, j)

                        End If

                    Next j

                Else

                    brr(2, N) = crr(k)

                    brr(14, N) = Arr(i, 14)

                    brr(15, N) = Arr(i, 15)

                End If

            Next k

        End If

    Next i

    For i = LBound(brr, 2) To UBound(brr, 2)

       brr(14, i) = Replace(brr(14, i), "深圳号-顺丰国际小包挂号", "USPS")

    Next i

    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    Set oSht = Wb.Worksheets(OTHER_SHEET_NAME)

    With oSht

            .UsedRange.Offset(1).ClearComments

            .Range("A2").Resize(UBound(brr, 2), UBound(brr)).Value = _

            Application.WorksheetFunction.Transpose(brr)

            .UsedRange.Columns.AutoFit

    End With

    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    UsedTime = VBA.Timer - StartTime

    MsgBox "本次耗时：" & Format(UsedTime, "0.000秒"), vbOKOnly, "NextSeven Excel Studio"

ErrorExit:

    Set Wb = Nothing

    Set Sht = Nothing

    Set Rng = Nothing

    Set oSht = Nothing

    Application.ScreenUpdating = True

    Application.DisplayAlerts = True

    Application.Calculation = xlCalculationAutomatic

    Application.StatusBar = False

    Exit Sub

    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

ErrHandler:

    If Err.Number <> 0 Then

        MsgBox Err.Description & "！", vbCritical, "NextSeven Excel Studio "

        'Debug.Print Err.Description

        Err.Clear

        Resume ErrorExit

    End If

End Sub