BankDailyAuto 帮用户自动抽取数据

近期帮用户自动抽取数据写的宏。

'WXHWYD
'This macro is for sorting data automatically only for Cummins casher
'Stones create on 2017/6/16
'Sub BankDailyAuto()
Sub AutoBankDaily()
    On Error GoTo ErrHandle
    'stop screen-updating for user so program runs more fast
    Application.ScreenUpdating = False
    
    'total line number of DataSource
    Dim TotalLineNum As Integer
    'last index of DataSource
    Dim LastRowNum As Integer
    'vender name
    Dim VendorName As String
    'description
    Dim Description As String
    'each row of transaction type in DataSource sheet
    Dim eachRowTranctionType As String
    'each row of Additional Comments in DataSource sheet
    Dim eachRowAdditionalComments As String
    'each row of ORDP row index
    Dim ORDPeachRowIndex As Integer
    'each row of REMI row index
    Dim REMIeachRowIndex As Integer
    'each row of BEMN row index
    Dim BEMNeachRowIndex As Integer
    'lenth of each row 's Addition Comments
    Dim LenOfAdditionComt As Integer
    
    'select "DataSource" sheet
    Sheets("DataSource").Select
    
    LastRowNum = 1
    Do While Range("A" & LastRowNum).Value <> ""
        LastRowNum = LastRowNum + 1
    Loop
    
    'get total line number of DataSource
    TotalLineNum = LastRowNum - 2
    
    'judge if user pasted data in DataSource sheet
    If TotalLineNum <= 0 Then
    MsgBox "please paste data in DataSource Sheet!"
    Exit Sub
    End If
    'get absolute value at column T
    Range("T2").Select
    ActiveCell.FormulaR1C1 = "=ABS(RC[-5])"
    Selection.AutoFill Destination:=Range("T2:T" & (LastRowNum - 1))
    'get absolute value at column U
    Range("U2").Select
    ActiveCell.FormulaR1C1 = "=ABS(RC[-5])"
    Selection.AutoFill Destination:=Range("U2:U" & (LastRowNum - 1))
    
    Range("T2:U" & (LastRowNum - 1)).Copy
    Sheets("Result").Select
    Range("I3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    'clear temp data column T and column U in DataSource sheet
    Sheets("DataSource").Select
    Range("T2:" & "U" & (LastRowNum - 1)).Select
    Selection.ClearContents
    
    'copy "Post Date" to 'Date' in sheet result from sheet Datasource
    Range("S2:" & "S" & (LastRowNum - 1)).Copy
    Sheets("Result").Select
    Range("A3").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Sheets("DataSource").Select
    
    'traverse datasource for each row
    For DataSourceRowIndex = 1 To TotalLineNum
       'get column "Mark" value
       '1.If Transaction Type is TFR+ then insert into Type Mark as 'Collections' in destination sheet.
       '2.If Transaction Type is TFR- and addition comments contain 'BENM' then insert into Type Mark as 'E-banking' in destination sheet.
       '3.If Transaction Type is TFR- and addition comments don’t contain 'BENM' then insert into Type Mark as 'Auto-payment' in destination sheet.
       'Column "W" is Vender Name
       'Column "X" is Description
       eachRowTranctionType = Range("M" & (DataSourceRowIndex + 1)).Value
       eachRowAdditionalComments = Range("K" & (DataSourceRowIndex + 1)).Value
       LenOfAdditionComt = Len(eachRowAdditionalComments)
       
       If eachRowTranctionType = "TFR+" Then
           'get column "Mark" value
           Range("V" & (DataSourceRowIndex + 1)).Select
           ActiveCell.FormulaR1C1 = "Collections"
           '"ORDP"
           If JG_ContainString(eachRowAdditionalComments, "ORDP") = "Y" Then
               ORDPeachRowIndex = InStr(eachRowAdditionalComments, "/ORDP/")
               '"REMI"
               If JG_ContainString(eachRowAdditionalComments, "REMI") = "Y" Then
                   REMIeachRowIndex = InStr(eachRowAdditionalComments, "/REMI/")
                   Range("W" & (DataSourceRowIndex + 1)).Select
                   ActiveCell.FormulaR1C1 = Mid(eachRowAdditionalComments, ORDPeachRowIndex + 6, REMIeachRowIndex - ORDPeachRowIndex - 6)
                   Range("X" & (DataSourceRowIndex + 1)).Select
                   ActiveCell.FormulaR1C1 = Mid(eachRowAdditionalComments, REMIeachRowIndex + 6)
               Else
                   Range("W" & (DataSourceRowIndex + 1)).Select
                   ActiveCell.FormulaR1C1 = Mid(eachRowAdditionalComments, ORDPeachRowIndex + 6)
               End If
           Else
               Range("W" & (DataSourceRowIndex + 1)).Select
               ActiveCell.FormulaR1C1 = eachRowAdditionalComments
           End If
       End If
       If eachRowTranctionType = "TFR-" Then
           If JG_ContainString(eachRowAdditionalComments, "BENM") = "Y" Then
               BENMeachRowIndex = InStr(eachRowAdditionalComments, "/BENM/")
               
           
                '"REMI"
                If JG_ContainString(eachRowAdditionalComments, "REMI") = "Y" Then
                    REMIeachRowIndex = InStr(eachRowAdditionalComments, "/REMI/")
                    Range("W" & (DataSourceRowIndex + 1)).Select
                    ActiveCell.FormulaR1C1 = Mid(eachRowAdditionalComments, BENMeachRowIndex + 6, REMIeachRowIndex - BENMeachRowIndex - 6)
                    Range("X" & (DataSourceRowIndex + 1)).Select
                    ActiveCell.FormulaR1C1 = Mid(eachRowAdditionalComments, REMIeachRowIndex + 6)
                    
                Else
                    Range("W" & (DataSourceRowIndex + 1)).Select
                    ActiveCell.FormulaR1C1 = Mid(eachRowAdditionalComments, BENMeachRowIndex + 6)
               End If
           
               'get column "Mark" value
               Range("V" & (DataSourceRowIndex + 1)).Select
               ActiveCell.FormulaR1C1 = "E-banking"
           Else
               
               Range("W" & (DataSourceRowIndex + 1)).Select
               ActiveCell.FormulaR1C1 = eachRowAdditionalComments
               
               'get column "Mark" value
               Range("V" & (DataSourceRowIndex + 1)).Select
               ActiveCell.FormulaR1C1 = "Auto-payment"
           End If
        End If
    Next
    
    Range("V2:V" & (LastRowNum - 1)).Copy
    Sheets("Result").Select
    Range("C3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    Sheets("DataSource").Select
    Range("W2:W" & (LastRowNum - 1)).Copy
    Sheets("Result").Select
    Range("F3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    Sheets("DataSource").Select
    Range("X2:X" & (LastRowNum - 1)).Copy
    Sheets("Result").Select
    Range("G3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    'clear temp data column T and column U in DataSource sheet
    Sheets("DataSource").Select
    Range("V2:" & "X" & (LastRowNum - 1)).Select
    Selection.ClearContents
ErrHandle:
    MsgBox "There is unexpected error .Please contact the administrator Stones Zhang ND936"
End Sub

Public Function JG_ContainString(SourceString As String, ContainString As String) As String
    If InStr(SourceString, ContainString) <> 0 Then JG_ContainString = "Y" Else JG_ContainString = "N"
End Function