Sub copyCurrentBankVod()
'
' copy current BankVod Macro
'
' copies selected BankVod data to CurrentBankVod.xlsx
'
'
Dim sourcewkbk As Workbook
Dim targetwkbk As Workbook
Dim Series As Range
Dim Filenm As String
Dim LRow As Long
On Error GoTo Error_Handler
'Set current open workbook as active workbook (should be orignating workbook)
Filenm = "U:\Enterprise Risk\ERA (Enterprise Risk Analytics)\ACCDBs\Loan Cost.RawData\CurrentBankVod.xlsx"
Set sourcewkbk = ActiveWorkbook
Set targetwkbk = Workbooks.Open(Filenm)
targetwkbk.Sheets("Sheet1").Activate
Cells.Select
Selection.ClearContents
targetwkbk.Save
'clear excel clipboard
Application.CutCopyMode = False
'make source wkbk active and copy selection
sourcewkbk.Activate
sourcewkbk.Sheets("Invoice Detail").Activate
Range("B:B, C:C, D:D, E:E, H:H").Select
Selection.Delete Shift:=xlToLeft
With sourcewkbk.Sheets("Invoice Detail")
.Range("A1:D" & Range("D" & Rows.Count).End(xlUp).Row).Copy
End With
'make target workbook active and paste values
targetwkbk.Activate
targetwkbk.Sheets("Sheet1").Activate
With targetwkbk.Sheets("Sheet1")
.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Skipblanks:=True, Transpose:=False
End With
LRow = ActiveSheet.UsedRange.Rows.Count
'add Vendor ID column
Columns("E:E").Select
Range("E1").Select
ActiveCell.FormulaR1C1 = "Vendor ID"
Range("E2").Select
ActiveCell.FormulaR1C1 = "8"
Range("E2").Select
Range("E2").AutoFill Destination:=Range("E2:E" & LRow)
'add Service ID column
Columns("F:F").Select
Range("F1").Select
ActiveCell.FormulaR1C1 = "Service ID"
Range("F2").Select
ActiveCell.FormulaR1C1 = "8"
Range("F2").Select
Range("F2").AutoFill Destination:=Range("F2:F" & LRow)
'add User ID
Columns("G:G").Select
Range("G1").Select
ActiveCell.FormulaR1C1 = "User"
Range("G2").Select
ActiveCell.FormulaR1C1 = "7"
Range("G2").Select
Range("G2").AutoFill Destination:=Range("G2:G" & LRow)
'add CostCenter
Columns("H:H").Select
Range("H1").Select
ActiveCell.FormulaR1C1 = "Cost Center"
Range("H2").Select
ActiveCell.FormulaR1C1 = "=IF(MID(TEXT(B2,"0000000"),2,1)="7",4,IF(MID(TEXT(B2,"0000000"),2,1)="5",8,IF(MID(TEXT(B2,"0000000"),2,1)="4",7,IF(MID(TEXT(B2,0000000),2,1)=3,10,IF(MID(TEXT(B2,"0000000"),2,1)="1",6,IF(MID(TEXT(B2,"0000000"),2,1)="0",5,11))))))" Range("H2").Select
Range("H2").AutoFill Destination:=Range("H2:H" & LRow)
targetwkbk.Save
targetwkbk.Close
'clear clipboard again
Application.CutCopyMode = False
'activate source wkbk, clear Sets and close
sourcewkbk.Activate
sourcewkbk.Close
Set targetwkbk = Nothing
Set sourcewkbk = Nothing
Exit_Procedure:
Exit Sub
Error_Handler:
MsgBox "An error has occurred in this application." _
& "Please contact your technical support and" _
& "tell them this information:" _
& vbCrLf & vbCrLf & "Error Number " & Err.Number & ", " _
& Err.Description, _
Buttons:=vbCritical, Title:="Excel TPSC"
Resume Exit_Procedure
End Sub
Bookmarks