Option Explicit
'program specific routine: this routine accepts the sheet name which contains the build up data from cms text files
'then it exports this data to appropriate monthly worksheets in the user defined export directory
Sub export_build_up_data_to_worksheets(xls_output_dir As String, ByRef build_up As Worksheet)
Dim i As Integer
Dim top_row As Integer
top_row = 1
Dim curr_filename As String
For i = 1 To xlLastRow(build_up.Name, ThisWorkbook.Name) + 1
If Month(build_up.Cells(top_row, 1)) <> Month(build_up.Cells(i, 1)) Or _
Year(build_up.Cells(top_row, 1)) <> Year(build_up.Cells(i, 1)) Or _
build_up.Cells(i, 1) = Null Then
'create/open export file
curr_filename = open_or_create_open_workbook(xls_output_dir, build_up.Cells(top_row, 1).value)
'export data to monthly workbook
Call export_build_up_to_dest_workbook(build_up, "Sheet1", curr_filename, top_row, i - 1)
'sort dest workbook
Call sort_worksheet("A1", "B1", "C1", "A:R", "Sheet1", curr_filename)
'remove dest work book duplicates
Call remove_duplicates("Sheet1", curr_filename)
'close workbook
Call close_workbook(curr_filename)
top_row = i
End If
Next
End Sub
Sub remove_duplicates(dest_worksheet As String, dest_workbook As String)
Application.Workbooks(dest_workbook).Worksheets(dest_worksheet).Select
Application.ScreenUpdating = False
columns("a:b").Insert
Rows(1).Insert: [a1] = "temp"
Dim r As Variant
r = Range("c" & Rows.Count).End(xlUp).row
Range("b2:b" & r).FormulaR1C1 = "=RC[1]&""|""&RC[2]&""|""&RC[3]"
Range("a2:a" & r).FormulaR1C1 = "=COUNTIF(R2C2:RC[1],RC[1])=1"
With Range("a1:a" & r)
.AutoFilter field:=1, Criteria1:="FALSE"
On Error Resume Next
.Offset(1).Resize(.Rows.Count, 1).SpecialCells(xlCellTypeVisible). _
EntireRow.Delete
On Error GoTo 0
.AutoFilter
End With
columns("a:b").Delete
Application.ScreenUpdating = True
End Sub
'progrem specific routine:
Sub export_build_up_to_dest_workbook(ByRef build_up As Worksheet, dest_worksheet_name As String, dest_workbook_name As String, start_row As Integer, end_row As Integer)
Dim last_row As Integer
last_row = xlLastRow(dest_worksheet_name, dest_workbook_name)
'If last_row = 0 Then last_row = last_row + 1
last_row = last_row + 1
build_up.Range("A" & start_row & ":S" & end_row).Copy Destination:=Application.Workbooks(dest_workbook_name).Worksheets(dest_worksheet_name).Range("A" & last_row)
End Sub
'program specific function: given a date as dt and path, will check to see if its corresponding yearly/monthly file exists, if not it will create,
'open workbook, and then return the filename to calling statement
Function open_or_create_open_workbook(xls_output_dir As String, dt As Variant) As String
Dim dest_path_full As String
dest_path_full = xls_output_dir & format_dir(Year(dt))
Dim dest_filename As String
'set up the correct path and filename
dest_filename = Year(dt) & "_" & MonthName(Month(dt)) & ".xls"
'if directory (based on year) does not exist, then create
If Not FileOrDirExists(dest_path_full) Then
MkDir (dest_path_full)
End If
'if file does not exist, create, else just open
If Not FileOrDirExists(dest_path_full & dest_filename) Then
open_new_workbook_file (dest_path_full & dest_filename)
Else
Workbooks.Open dest_path_full & dest_filename
End If
'send back the filename we have calculated
open_or_create_open_workbook = dest_filename
End Function
'program specific routines (next two): this function will confirm the validity of the imported text file against
'what the cms input file should look like
Function split_skill_report_daily_validity_check(ByRef target_sheet As Worksheet) As Boolean
If IsDate(target_sheet.Range("A1").value) Then
If Trim(target_sheet.Range("A3").value) = "Totals" Then
If xlLastRow(target_sheet.Name, ThisWorkbook.Name) > 3 Then
split_skill_report_daily_validity_check = True
Exit Function
End If
End If
End If
split_skill_report_daily_validity_check = False
End Function
Function agent_split_skill_daily_validity_check(ByRef target_sheet As Worksheet) As Boolean
If Trim(target_sheet.Range("A2")) = "Totals" Then
If IsDate(Trim(target_sheet.Range("A3"))) Then
If xlLastRow(target_sheet.Name, ThisWorkbook.Name) > 2 Then
agent_split_skill_daily_validity_check = True
Exit Function
End If
End If
End If
agent_split_skill_daily_validity_check = False
End Function
'program specific routine: obtains row number as a parameter and adds to build_up worksheet from temp_working
Sub copy_temp_working_to_build_up_splitskillreportdaily(row As Integer, ByRef temp_working As Worksheet, ByRef build_up As Worksheet)
'copy date
temp_working.Range("A1").Copy Destination:=build_up.Range("A" & xlLastRow(build_up.Name, ThisWorkbook.Name) + 1)
'copy agent name
temp_working.Range("A" & row).Copy Destination:=build_up.Range("B" & xlLastRow(build_up.Name, ThisWorkbook.Name))
'copy skill
temp_working.Range("A2").Copy Destination:=build_up.Range("C" & xlLastRow(build_up.Name, ThisWorkbook.Name))
'copy acd calls
temp_working.Range("B" & row).Copy Destination:=build_up.Range("D" & xlLastRow(build_up.Name, ThisWorkbook.Name))
'copy acd time
temp_working.Range("E" & row).Copy Destination:=build_up.Range("E" & xlLastRow(build_up.Name, ThisWorkbook.Name))
'copy acw time
temp_working.Range("F" & row).Copy Destination:=build_up.Range("F" & xlLastRow(build_up.Name, ThisWorkbook.Name))
'calculate, then copy held time
build_up.Range("G" & xlLastRow(build_up.Name, ThisWorkbook.Name)) = VBA.Round(temp_working.Range("N" & row).value * temp_working.Range("O" & row).value)
End Sub
'program specific routine: obtains row number as a parameter and adds to build_up worksheet from temp_working
Sub copy_temp_working_to_build_up_agentsplitskillreport(row As Integer, ByRef temp_working As Worksheet, ByRef build_up As Worksheet)
'copy date
temp_working.Range("A" & row).Copy Destination:=build_up.Range("A" & xlLastRow(build_up.Name, ThisWorkbook.Name) + 1)
'copy agent name
temp_working.Range("A1").Copy Destination:=build_up.Range("B" & xlLastRow(build_up.Name, ThisWorkbook.Name))
'copy skill
temp_working.Range("B" & row).Copy Destination:=build_up.Range("C" & xlLastRow(build_up.Name, ThisWorkbook.Name))
'copy acd calls
temp_working.Range("C" & row).Copy Destination:=build_up.Range("D" & xlLastRow(build_up.Name, ThisWorkbook.Name))
'copy acd time
temp_working.Range("D" & row).Copy Destination:=build_up.Range("E" & xlLastRow(build_up.Name, ThisWorkbook.Name))
'copy acw time
temp_working.Range("E" & row).Copy Destination:=build_up.Range("F" & xlLastRow(build_up.Name, ThisWorkbook.Name))
'copy held time
temp_working.Range("L" & row).Copy Destination:=build_up.Range("G" & xlLastRow(build_up.Name, ThisWorkbook.Name))
End Sub
'####################################################################################################################################################
'routine simply creates a new excel file given the path and filename, saves and leaves open
Sub open_new_workbook_file(path_filename As String)
Dim NewBook As Workbook
Set NewBook = Workbooks.Add
NewBook.SaveAs Filename:=path_filename
End Sub
'routine closes an excel file given teh path and filename
Sub close_workbook(dest_filename As String)
Dim dest_book As Workbook
Set dest_book = Workbooks(dest_filename)
With dest_book
.Save
.Close
End With
End Sub
'borrowed function, url: http://www.vbaexpress.com/kb/getarticle.php?kb_id=559
'checks if file or directory exists.
Function FileOrDirExists(PathName As String) As Boolean
Dim iTemp As Integer
'Ignore errors to allow for error evaluation
On Error Resume Next
iTemp = GetAttr(PathName)
'Check if error exists and set response appropriately
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select
'Resume error checking
On Error GoTo 0
End Function
'this function accepts a string, checks if it ends with a backslash, if it doesn't it returns input with a backslash
Function format_dir(dir As String) As String
If Right(dir, 1) <> "\" Then
format_dir = dir & "\"
Else
format_dir = dir
End If
End Function
'borrowed function - url: unknown
'finds the last row in the given worksheet name
Function xlLastRow(Optional WorksheetName As String, Optional workbook_name As String) As Long
'if no sheet name supplied use current worksheet name
If WorksheetName = vbNullString Then WorksheetName = ActiveSheet.Name
If workbook_name = vbNullString Then workbook_name = ThisWorkbook.Name
With Application.Workbooks(workbook_name).Worksheets(WorksheetName)
On Error Resume Next
xlLastRow = .Cells.Find("*", .Cells(1), xlFormulas, _
xlWhole, xlByRows, xlPrevious).row
If Err <> 0 Then xlLastRow = 0
End With
End Function
'routine will add an array element to the end of the given array, it will initialise if not already initialised.
Sub push_array(value As Variant, ByRef this_array() As Variant)
On Error GoTo intialiseArray
If Not (IsEmpty(this_array(0))) Then
ReDim Preserve this_array(UBound(this_array()) + 1)
End If
this_array(UBound(this_array())) = value
Exit Sub
intialiseArray:
ReDim this_array(0)
Resume
End Sub
'borrowed and slightly modifed function - url: unknown
'This function given a mask such as "c:\*.txt"
'will return an array of all files matching the criteria
Function return_file_list(path As String, mask As String) As Variant()
Dim temp_working As String
Dim file_lst() As Variant
Dim counter As Long
ReDim file_lst(0) As Variant
temp_working = dir(path & mask, vbNormal)
Do While Len(temp_working)
counter = UBound(file_lst) + 1
Call push_array(temp_working, file_lst())
temp_working = dir
Loop
return_file_list = file_lst
End Function
'Borrowed (& modified) function - url: http://www.dailydoseofexcel.com/archives/2005/02/08/import-text-in-vba/
'Reads in the cms source text files, given the location + delimiter, and writes file contents into sheet3 starting cell 1,1
Sub load_cms_text_file(file_loc As String, dest_worksheet As String, dest_workbook_name As String, delim As Variant)
Dim sFile As String
Dim sInput As String
Dim lFNum As Long
Dim vaFields As Variant
Dim i As Long
Dim lRow As Long
Dim vaStrip As Variant
Dim sDELIM As Variant
sDELIM = delim
lFNum = FreeFile
sFile = file_loc
vaStrip = Array(vbLf, vbTab)
Open sFile For Input As lFNum
'Loop through the file until the end
Do While Not EOF(lFNum)
Line Input #lFNum, sInput
For i = LBound(vaStrip) To UBound(vaStrip)
sInput = Replace(sInput, vaStrip(i), "")
Next i
vaFields = Split(sInput, sDELIM)
lRow = lRow + 1
For i = 0 To UBound(vaFields)
Application.Workbooks(dest_workbook_name).Worksheets(dest_worksheet).Cells(lRow, i + 1).value = vaFields(i)
Next i
Loop
Close lFNum
End Sub
'obtains message string and worksheet name - appends message to worksheet - used for logging messages (errors, results, etc)
Sub write_to_log(message As String, sheet_name As String, workbook_name As String)
Dim target_sheet As Worksheet
Set target_sheet = Application.Workbooks(workbook_name).Worksheets(sheet_name)
target_sheet.Activate
target_sheet.Range("A" & xlLastRow(target_sheet.Name, workbook_name) + 1) = Now() & ": " & message
End Sub
'sub routine accepts a column range and worksheet name - then executes statement: texttocolumns
Sub text_to_columns(colms As String, sheet_name As String, workbook_name As String)
Application.Workbooks(workbook_name).Sheets(sheet_name).Select
columns(colms).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 4), TrailingMinusNumbers:=True
End Sub
'sub routine requires key1, 2 and 3 ... sorts given worksheet name using the given keys
Sub sort_worksheet(key_1 As Variant, key_2 As Variant, key_3 As Variant, colms As String, sheet_name As String, workbook_name As String)
Application.Workbooks(workbook_name).Sheets(sheet_name).Select
columns(colms).Sort Key1:=Range(key_1), Order1:=xlAscending, Key2:=Range _
(key_2), Order2:=xlAscending, Key3:=Range(key_3), Order3:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, _
DataOption3:=xlSortNormal
End Sub
