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

　　

转载于:https://www.cnblogs.com/nextseven/p/7129166.html