使用Excel宏实现数据自动处理

因为工作关系,需要对一些数据进行一些重复性的处理工作,为了提高效率,录制宏进行重复处理非常有效,但录制的宏有大量无效代码,而且需要处理的数据源有两种不同的格式,通过宏录制和自己的处理,可以很好的解决这些问题。

 

Option Explicit

Sub SpareCatalogueFormat()
    Dim sMessage As String
    Dim answer As Integer
    
    On Error GoTo ErrHandler01
    
    sMessage = "Do you want to convert data to SPARE PARTS CATALOGUE format?" & vbCrLf & vbCrLf & _
               "To do that you must paste data from CADIM to cells from ""A1""." & vbCrLf & vbCrLf & _
               "Press ""OK"" to continue, and Press ""Cancel"" to exit."
    answer = MsgBox(sMessage, vbOKCancel + vbQuestion, "User Question:")
    If answer = vbOK Then
        '''do nothing
    ElseIf answer = vbCancel Then
        End
    End If


    ''' Check the minumium value of column A to identify this is BoM list
    ''' from Scope of Supply or Assembly and Components. For SoS, column A
    ''' is DWG Pos. No., so it starts from 1, for AaC, column A is Position
    ''' and it starts from 10 or a even bigger number.
    Range("S1").Cells(1, 1) = "=MIN(A:A)"
    If Range("S1").Cells(1, 1).Value = 1 Then
        Call Format1(True)
    ElseIf Range("S1").Cells(1, 1).Value > 1 Then
        Call Format2(True)
    Else
        MsgBox "Unkown error! Please check the VBA code!", vbCritical
        End
    End If
    
    Exit Sub
    
ErrHandler01:
    sMessage = "Ooops! Something didn't work quite correctly." & vbCrLf & vbCrLf & _
        "Error number: " & Err.Number & vbCrLf & _
        "Error message: " & Err.Description & vbCrLf & vbCrLf & _
        "Please check the VBA code!"
    MsgBox sMessage, vbOKOnly + vbCritical, "iFE-VICTALL, Knorr-Bremse"
    End
End Sub

Sub Format1(ByVal b As Boolean)

    On Error GoTo ErrHandler01
    
    ''' Input formula, if there is no English description, use German description
    ''' with brackets, if both English and German description do not exist,
    ''' leave the cell blank.
    Range("J1").Cells(1, 1) = _
        "=PROPER(IF(TRIM(RC[-4])<>"""",RC[-4],IF(TRIM(RC[-5])<>"""",""(""&RC[-5]&"")"","""")))"
    Range("J1").Select
    Selection.AutoFill Destination:=Range("J1:J1000"), Type:=xlFillDefault
    
    
    ''' Move description cells value
    Range("J1:J1000").Select
    Selection.Copy
    Range("E1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    
    ''' Keep this column for customer part number.
    Columns("D:D").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    
    
    ''' Delete useless columns.
    Columns("F:F").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Delete Shift:=xlToLeft
    
    
    ''' Insert header row
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    
    ''' Move column piece/door
    Columns("B:B").Select
    Selection.Cut
    Columns("F:F").Select
    Selection.Insert Shift:=xlToRight
    
    ''' Input first row content, table header
    Range("F1").Cells(1, 1) = "Type"
    Range("E1").Cells(1, 1) = "Piece/door"
    Range("D1").Cells(1, 1) = "Description"
    Range("C1").Cells(1, 1) = "Customer Part No."
    Range("B1").Cells(1, 1) = "IFE Part No."
    Range("A1").Cells(1, 1) = "Pos No."
    
    
    ''' Set borders and other format, also sort data
    Cells.Select
    Selection.FormatConditions.Delete
    With Selection
        .FormatConditions.Delete
        .Borders.LineStyle = xlNone
    End With

    
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    With Selection
        .HorizontalAlignment = xlLeft
        With .Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
    End With
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
        , Order2:=xlAscending, Key3:=Range("D2"), Order3:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
        xlSortNormal
    Columns("A:F").EntireColumn.AutoFit
    
    ''' Set format of first row
    Range("A1:F1").Select
    With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    
    Range("A1").Select
    Exit Sub
    
ErrHandler01:
    sMessage = "Ooops! Something didn't work quite correctly." & vbCrLf & vbCrLf & _
        "Error number: " & Err.Number & vbCrLf & _
        "Error message: " & Err.Description & vbCrLf & vbCrLf & _
        "Please check the VBA code!"
    MsgBox sMessage, vbOKOnly + vbCritical, "iFE-VICTALL, Knorr-Bremse"
    End
End Sub

Sub Format2(ByVal b As Boolean)

    On Error GoTo ErrHandler01
    
    ''' Input formula, if there is no English description, use German description
    ''' with brackets, if both English and German description do not exist,
    ''' leave the cell blank.
    Range("F1").Cells(1, 1) = _
        "=PROPER(IF(TRIM(RC[5])<>"""",RC[5],IF(TRIM(RC[4])<>"""",""(""&RC[4]&"")"","""")))"
    Range("F1").Select
    Selection.AutoFill Destination:=Range("F1:F1000")
    
    ''' Move description cells value
    Range("F1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("K1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    
    ''' Delete useless columns.
    Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    
    Columns("C:D").Select
    Selection.Delete Shift:=xlToLeft
    
    Columns("D:F").Select
    Selection.Delete Shift:=xlToLeft
    
    Columns("E:Q").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Delete Shift:=xlToLeft
    
    
    ''' Insert header row
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    
    
    ''' Adjust sequence of columns
    Columns("B:B").Select
    Selection.Cut
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight
    
    Columns("E:E").Select
    Selection.Cut
    Columns("D:D").Select
    Selection.Insert Shift:=xlToRight
    
    
    ''' Input first row content, table header
    Range("F1").Cells(1, 1) = "Type"
    Range("E1").Cells(1, 1) = "Piece/door"
    Range("D1").Cells(1, 1) = "Description"
    Range("C1").Cells(1, 1) = "Customer Part No."
    Range("B1").Cells(1, 1) = "IFE Part No."
    Range("A1").Cells(1, 1) = "Pos No."
    
    
    ''' Set borders and other format, also sort data
    Cells.Select
    Selection.FormatConditions.Delete
    With Selection
        .FormatConditions.Delete
        .Borders.LineStyle = xlNone
    End With

    
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    With Selection
        .HorizontalAlignment = xlLeft
        With .Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
    End With
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
        , Order2:=xlAscending, Key3:=Range("D2"), Order3:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
        xlSortNormal
    Columns("A:F").EntireColumn.AutoFit
    
    ''' Set format of first row
    Range("A1:F1").Select
    With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    
    Range("A1").Select
    
    Exit Sub
    
ErrHandler01:
    sMessage = "Ooops! Something didn't work quite correctly." & vbCrLf & vbCrLf & _
        "Error number: " & Err.Number & vbCrLf & _
        "Error message: " & Err.Description & vbCrLf & vbCrLf & _
        "Please check the VBA code!"
    MsgBox sMessage, vbOKOnly + vbCritical, "iFE-VICTALL, Knorr-Bremse"
    End
End Sub


发布了13 篇原创文章 · 获赞 7 · 访问量 17万+
展开阅读全文

没有更多推荐了,返回首页

©️2019 CSDN 皮肤主题: 大白 设计师: CSDN官方博客

分享到微信朋友圈

×

扫一扫,手机浏览