Show Case
Overview
This will be a quick summary for those who do not want to know the detailed implementation.
The reason for this codes existance is to create a way to space delimit each character of the txt file that
is to be submitted. It needed some very specific parameters.
EAMS BULK Filing Specifications
Given the high level of specificity needed for this, it was a perfect place for a program to automate
away a few hours of work.
The basic execution is, it takes these three sheets: AccountingDoc, EmployeeData, and CompanyData. The
AccountingDoc sheet is the input sheet where each character of the cell data in EmployeeData and CompanyData
is place.
So as a quick example:
I hope this shows what it is that it does. You will notice that the characters from cell
A2 have been spread out into cells B2 - J2 in the final format.
There are a lot of other caviots, but that is the basic idea.
The Breakdown:
PopulatBulkFile()
Sub PopulatBulkFile()
Dim PopulateSheet As Worksheet
Dim CompanySheet As Worksheet
Dim EmployeeSheet As ListObject
Set PopulateSheet = Workbooks("InProgressTemplate.xlsm").Worksheets("AccountingDoc")
Set CompanySheet = Workbooks("InProgressTemplate.xlsm").Worksheets("CompanyData")
Set EmployeeSheet = Workbooks("InProgressTemplate.xlsm").Worksheets("EmployeeData").ListObjects("Table1")
' Input the data
PopulateSRec PopulateSheet, EmployeeSheet
PopulateTRec PopulateSheet, CompanySheet, EmployeeSheet
PopulateFRec PopulateSheet, CompanySheet, EmployeeSheet
FormatBulkFile PopulateSheet
SaveSheet PopulateSheet
End Sub
It starts off very simply describing the high level process of execution. I brought in the three sheets,
then populated the data from the data sheets into the AccountingData sheet and save the sheet as a new workbook.
Done!
Hardly... I will start with the population of the T and F records as they are much simpler.
PopulateFRec()
I'm going to start with the F record. It is the shortest so I will be able to lay down some basics of the other two functions work.
Sub PopulateFRec(PopulateSheet, CompanySheet, DataTable)
Dim LowerBound(1 To 23)
Dim UpperBound(1 To 23)
Dim FRow As Integer
PopulateSheet.Activate
GetFLower LowerBound
GetFUpper UpperBound
'''Get the location of the F Record
FRow = FindRecord(PopulateSheet, "F")
'''enter total employer T Records
PopulateSheet.Cells(FRow, UpperBound(3)) = "1"
For i = 4 To 9
'''zero value all cells
PopulateSheet.Range(PopulateSheet.Cells(FRow, LowerBound(i)), PopulateSheet.Cells(FRow, UpperBound(i))) = "0"
'''Get data from the Columns of CompanyData Sheet and populate to PopulateSheet From right to left
FieldSearch = FindRecord(CompanySheet, PopulateSheet.Cells(FRow - 1, LowerBound(i)))
DataValue = CompanySheet.Cells(FieldSearch, 2)
For j = 0 To Len(DataValue) - 1
PopulateSheet.Cells(FRow, UpperBound(i) - j) = Left(Right(DataValue, j + 1), 1)
Next j
Next i
End Sub
The variables defined here are defined through each of the functions. First there is the LowerBound[] and UpperBound[] arrays. These will store the values of the range of column indeces that the current cells characters will be seperated into.
Function GetFLower(LowerBound)
LowerBound(1) = 1 '''Constant F
LowerBound(2) = 22 '''Constant UTAX
LowerBound(3) = 12 '''Always be 1
LowerBound(4) = 2
LowerBound(5) = 41
LowerBound(6) = 56
LowerBound(7) = 71
LowerBound(8) = 86
LowerBound(9) = 140
LowerBound(10) = 155 '''Blank or 4 digits
End Function
Function GetFUpper(UpperBound)
UpperBound(1) = 1 '''Constant F
UpperBound(2) = 25 '''Constant UTAX
UpperBound(3) = 21
UpperBound(4) = 11
UpperBound(5) = 55
UpperBound(6) = 70
UpperBound(7) = 85
UpperBound(8) = 100
UpperBound(9) = 154
UpperBound(10) = 158 '''Blank or 4 digits
End Function
These values are defined by the EAMS Bulk filing specifications.
Next The FRow variable is defined. This is the the row number that the "F" data will be put into.
FindRecord()
To find the "F" row I pass in the sheet I want to search and the string to search for.
...
Dim FRow As Integer
...
FRow = FindRecord(PopulateSheet, "F")
...
Function FindRecord(PopulateSheet, FindRec)
Dim location As Range
With PopulateSheet.Range("A:A")
Set location = .Find(FindRec, LookIn:=xlValues, LookAt:=xlWhole)
End With
FindRecord = location.Cells.Row
End Function
This function works by looking in Column A and finding the first instance where the cell value equals the FindRec string that was passed to it. I then returns the row number it was found in.
...
FieldSearch = FindRecord(CompanySheet, PopulateSheet.Cells(FRow - 1, LowerBound(i)))
...
Here the CompanyData sheet is searched using the string that is one row up, in the first
cell of the current range. So the first search term will be "Total Number of Employees", and the row that
string is found in within the CompanyData sheet will be returned.
...
DataValue = CompanySheet.Cells(FieldSearch, 2)
...
For j = 0 To Len(DataValue) - 1
PopulateSheet.Cells(FRow, UpperBound(i) - j) = Left(Right(DataValue, j + 1), 1)
Next j
...
Next the value in column 2 is collected. Then one of the important formatting characteristics come into play.
In this case the cell value must be populated in the right most cell first. So in the for loop
I get the length of the string and each character is pull out from right to left and put into the cell
UpperBound(i) - j.
Of course the Left(Right(DataValue, j + 1), 1) could be replaced with a simpler
MID(DataValue, Len(DataValue) - j, 1).
This process is then done for each of the LowerBound and UpperBound ranges.
So this is the process that is run for each of the other records S and T. I will go through each of those breifly
and only highlight the important bits.
PopulateTRec()
Sub PopulateTRec(PopulateSheet, CompanySheet, DataTable)
Dim LowerBound(1 To 23) As Integer
Dim UpperBound(1 To 23) As Integer
Dim TRow As Integer
Dim FieldSearch As Integer
Dim DataValue As String
PopulateSheet.Activate
GetTLower LowerBound
GetTUpper UpperBound
TRow = FindRecord(PopulateSheet, "T")
For i = 3 To 22
PopulateSheet.Range(PopulateSheet.Cells(TRow, LowerBound(i)), PopulateSheet.Cells(TRow, UpperBound(i))) = "0"
'''Get data from the Columns of CompanyData Sheet and populate to PopulateSheet
FieldSearch = FindRecord(CompanySheet, PopulateSheet.Cells(TRow - 1, LowerBound(i)))
DataValue = CompanySheet.Cells(FieldSearch, 2)
For j = 0 To Len(DataValue) - 1
PopulateSheet.Cells(TRow, UpperBound(i) - j) = Left(Right(DataValue, j + 1), 1)
Next j
Next i
End Sub
The T Record is basically the same thing as the F Record with the major differences being the UpperBounds and LowerBounds. Also it looks for the T record row, naturally.
PopulateSRec()
Sub PopulateSRec(PopulateSheet, DataTable)
Dim LowerBound(1 To 18) As Integer
Dim UpperBound(1 To 18) As Integer
Dim TotalEmployees As Integer
Dim SRow As Range
PopulateSheet.Activate
GetLower LowerBound
GetUpper UpperBound
TotalEmployees = DataTable.DataBodyRange.Rows.Count
'''Set T Record total employee count
PopulateSheet.Range(Cells(12, 2), Cells(12, 8)) = "0"
For i = 0 To Len(EmployeeCount) - 1
PopulateSheet.Cells(12, 8 - i) = Left(Right(TotalEmployees, i + 1), 1)
Next i
'''Zero the sheet to populate
Set SRow = PopulateSheet.Range("A6")
Do
If SRow.Offset(2, 0) <> "Record Identifier" Then
SRow.Offset(1, 0).EntireRow.Delete
End If
Loop Until Not SRow.Offset(2, 0) <> "Record Identifier"
For i = 0 To TotalEmployees - 1
CurrentRow = i + 7
Rows(CurrentRow).EntireRow.Insert
PopulateSheet.Cells(CurrentRow, LowerBound(1)) = "S"
For m = 1 To Len("UTAX")
PopulateSheet.Cells(CurrentRow, LowerBound(17) + m - 1) = Left(Mid("UTAX", m), 1)
Next m
'''Social should have "I" if not filled
PopulateSheet.Range(Cells(CurrentRow, LowerBound(2)), Cells(CurrentRow, UpperBound(2))) = "I"
'''Period month
ReportingMonth = Worksheets("ReferenceData").Range("D2") & Worksheets("ReferenceData").Range("C2")
For m = 1 To Len(ReportingMonth)
PopulateSheet.Cells(CurrentRow, LowerBound(18) + m - 1) = Left(Mid(ReportingMonth, m), 1)
Next m
ColumnNum = 5
'''Go through value that are right aligned
For L = 11 To 16
With PopulateSheet
If Not L <> 16 And DataTable.DataBodyRange(i + 1, ColumnNum) = "" Then
Range(Cells(CurrentRow, LowerBound(16)), Cells(CurrentRow, UpperBound(16))) = ""
Else
Range(Cells(CurrentRow, LowerBound(L)), Cells(CurrentRow, UpperBound(L))) = 0
End If
CellValue = DataTable.DataBodyRange(i + 1, ColumnNum)
For j = 0 To Len(CellValue) - 1
Cells(CurrentRow, UpperBound(L) - j) = Left(Right(CellValue, j + 1), 1)
Next j
End With
ColumnNum = ColumnNum + 1
Next L
ColumnNum = 1
'''Go through left aligned content
For k = 2 To 10
With PopulateSheet
'''Get the value of the data cell
CellValue = DataTable.DataBodyRange(i + 1, ColumnNum)
'''populate the characters one at a time in the columns
For j = 0 To Len(CellValue) - 1
Cells(CurrentRow, LowerBound(k) + j) = Left(Mid(CellValue, j + 1), 1)
Next j
End With
ColumnNum = ColumnNum + 1
If Not ColumnNum <> 5 Then
ColumnNum = 11
End If
Next k
Next i
End Sub
Function GetLower(LowerBound)
LowerBound(1) = 1 '''constant "S"
'''Left justified content
LowerBound(2) = 2
LowerBound(3) = 11
LowerBound(4) = 31
LowerBound(5) = 43
LowerBound(6) = 147
LowerBound(7) = 210
LowerBound(8) = 212
LowerBound(9) = 213
LowerBound(10) = 214
'''right justified content
LowerBound(11) = 44
LowerBound(12) = 50 '''0 fill
LowerBound(13) = 64 '''0 fill
LowerBound(14) = 78 '''0 fill
LowerBound(15) = 92 '''0 fill
LowerBound(16) = 132 '''0 fill unless blank then space fill
LowerBound(17) = 143 '''Constant UTAX
LowerBound(18) = 215 '''Format MMYYYY
End Function
Function GetUpper(UpperBound)
UpperBound(1) = 1 '''constant "S"
'''Left justified content
UpperBound(2) = 10
UpperBound(3) = 30
UpperBound(4) = 42
UpperBound(5) = 43
UpperBound(6) = 161
UpperBound(7) = 210
UpperBound(8) = 212
UpperBound(9) = 213
UpperBound(10) = 214
'''right justified content
UpperBound(11) = 45
UpperBound(12) = 63 '''0 fill
UpperBound(13) = 77 '''0 fill
UpperBound(14) = 91 '''0 fill
UpperBound(15) = 105 '''0 fill
UpperBound(16) = 135 '''0 fill unless blank then space fill
UpperBound(17) = 146 '''Constant UTAX
UpperBound(18) = 220 '''format MMYYYY
End Function
Check out the full code for Populating the S record above or read on to learn the important bits.
Dim LowerBound(1 To 18) As Integer
Dim UpperBound(1 To 18) As Integer
Dim TotalEmployees As Integer
Dim SRow As Range
PopulateSheet.Activate
GetLower LowerBound
GetUpper UpperBound
As per usual varibles are defined and I get the upper and lower bounds for this section.
TotalEmployees = DataTable.DataBodyRange.Rows.Count
'''Set T Record total employee count
PopulateSheet.Range(Cells(12, 2), Cells(12, 8)) = "0"
For i = 0 To Len(EmployeeCount) - 1
PopulateSheet.Cells(12, 8 - i) = Left(Right(TotalEmployees, i + 1), 1)
Next i
Using the table function in excel to get the total number of rows, each row contains all employee info. This range is first zeroed out as per specs, it is then populated from right to left.
Do
If SRow.Offset(2, 0) <> "Record Identifier" Then
SRow.Offset(1, 0).EntireRow.Delete
End If
Loop Until Not SRow.Offset(2, 0) <> "Record Identifier"
Here all the old data is removed if it was not previously cleared out. This is more of a quality of life function and not strictly neccessary. The reason it is looking for "Record Identifier" is because that is the name of the cell that is below the S record if there is only one S Record Row.
For i = 0 To TotalEmployees - 1
CurrentRow = i + 7
Rows(CurrentRow).EntireRow.Insert
PopulateSheet.Cells(CurrentRow, LowerBound(1)) = "S"
For m = 1 To Len("UTAX")
PopulateSheet.Cells(CurrentRow, LowerBound(17) + m - 1) = Left(Mid("UTAX", m), 1)
Next m
'''Social should have "I" if not filled
PopulateSheet.Range(Cells(CurrentRow, LowerBound(2)), Cells(CurrentRow, UpperBound(2))) = "I"
'''Period month
ReportingMonth = Worksheets("ReferenceData").Range("D2") & Worksheets("ReferenceData").Range("C2")
For m = 1 To Len(ReportingMonth)
PopulateSheet.Cells(CurrentRow, LowerBound(18) + m - 1) = Left(Mid(ReportingMonth, m), 1)
Next m
I then begin to loop through all of the employees. The CurrentRow is defined and the next data row is inserted. Next some constant values are populated.
ColumnNum = 5
'''Go through value that are right aligned
For L = 11 To 16
With PopulateSheet
If Not L <> 16 And DataTable.DataBodyRange(i + 1, ColumnNum) = "" Then
Range(Cells(CurrentRow, LowerBound(16)), Cells(CurrentRow, UpperBound(16))) = ""
Else
Range(Cells(CurrentRow, LowerBound(L)), Cells(CurrentRow, UpperBound(L))) = 0
End If
CellValue = DataTable.DataBodyRange(i + 1, ColumnNum)
For j = 0 To Len(CellValue) - 1
Cells(CurrentRow, UpperBound(L) - j) = Left(Right(CellValue, j + 1), 1)
Next j
End With
ColumnNum = ColumnNum + 1
Next L
ColumnNum = 1
'''Go through left aligned content
For k = 2 To 10
With PopulateSheet
'''Get the value of the data cell
CellValue = DataTable.DataBodyRange(i + 1, ColumnNum)
'''populate the characters one at a time in the columns
For j = 0 To Len(CellValue) - 1
Cells(CurrentRow, LowerBound(k) + j) = Left(Mid(CellValue, j + 1), 1)
Next j
End With
ColumnNum = ColumnNum + 1
If Not ColumnNum <> 5 Then
ColumnNum = 11
End If
Next k
The Final operation is to populate the left and right justified content. There is some exeptions within the data to
how the data should be filled and so those have also been accounted for. These exceptions can be found in the Bulk
Filing Specs or in the UpperBound and LowerBound defined variables in the full code.
The ColumnNum defines the column to get the data from in the EmployeeData Sheet. i + 1
is used because i starts at 0 and tables start at 1, so row 0 does not exist.
FormatBulkFile()
The next Operation in the main function is to format the cells. This Removes some of the orginizing data that is neccessary for creation but will no be included in the final sheet for submission. It also some does operations because a .prn file is a pain and needs some very specific direction to work properly.
Function FormatBulkFile(PopulateSheet)
' Dim PopulateSheet As Worksheet
Dim FinalFormat As Worksheet
Dim LastS As String
Dim FirstS As Integer
Dim LastRow As Integer
' Set PopulateSheet = Workbooks("InProgressTemplate.xlsm").Worksheets("AccountingDoc")
PopulateSheet.Activate
PopulateSheet.Copy Before:=PopulateSheet
Set FinalFormat = Workbooks("InProgressTemplate.xlsm").Sheets(1)
FinalFormat.Activate
' delete formating data
Range("A1").EntireRow.Delete
Range("A1").EntireRow.Delete
Range("A2").EntireRow.Delete
Range("A3").EntireRow.Delete
' Find first S
' Find last S
FirstS = FindRecord(FinalFormat, "S")
LastS = FindLastRec(FinalFormat, FirstS)
LastRow = Range(LastS).Cells.Row + 2
' more formating data
Range(LastS).Offset(1, 0).EntireRow.Delete
Range(LastS).Offset(1, 0).EntireRow.Delete
Range(LastS).Offset(2, 0).EntireRow.Delete
' Put "i" in a new column at the point that the prn file will split the data this will be removed,
' This is neccessary to retain all the spaces as a prn will remove these spaces
Range("IF1").EntireColumn.Insert
Range("IF1:IF" & LastRow) = "i"
Range("JQ1:JQ" & LastRow) = "i"
Range("A1:JQ1").ColumnWidth = 1.2
End Function
It starts by copying the first sheet which is the sheet that all data was populated into, it is renamed to
FinalFormat. Then some Organizing data is removed.
The last couple operations are for the sake of the .prn file format. First a row is add at column IF,
this is so it is easier to remove the add "i" characters. These characters are add from top to bottom
at position 240 because a .prn file can only have 240 characters perline and will remove trailing spaces after the last
character if this. This means all characters will be retained.
Lastly a ColumnWidth of 1.2 is set. This is in the range that will make the .prn file
put only one character. If this is too small the character will not be printed, if it is too large it will add extra
characters.
SaveSheet()
Next the PopulateBulkFile() saves the newly populated sheet. This would seem to be a simple task but this is a government document so it needs to fulfill specific requirements. This involves creating a .prn file (space delimited file type), then modifying that file because .prn files do not just work.
Function SaveSheet(PopulateSheet)
Dim LastRow As Integer
Dim LastWorkbook As Integer
PopulateSheet.Activate
ActiveSheet.Move
LastWorkbook = Workbooks.Count
Workbooks(LastWorkbook).Activate
' get the last row in the current sheet
LastRow = FindRecord(ActiveSheet, "F")
' Automatically overwrite any file with this name without any UI
Application.DisplayAlerts = False
ActiveSheet.SaveAs Filename:="C:\tmp\tmpBulkFile.prn", FileFormat:=xlTextPrinter
' close and reopen the file to allow it to default to its stupid state
Workbooks("tmpBulkFile.prn").Close
Workbooks.Open "C:\tmp\tmpBulkFile.prn"
Workbooks("tmpBulkFile.prn").Activate
' create a new sheet
Sheets.Add Before:=ActiveSheet
Sheets(1).Activate
' Loop through all the rows and concatinate the split data
' ensure that all columns are of width 1.22 or data will be missing or added
For i = 1 To LastRow
Range("A" & i) = Left(Worksheets("tmpBulkFile").Range("A" & i), 239) & Left(Worksheets("tmpBulkFile").Range("A" & LastRow + i), 36)
Next i
' delete the origonal sheet
Sheets(2).Delete
' Remove the trailing tabs that cause quotation marks
WriteTotxtRemoveQuotation LastRow
Workbooks("tmpBulkFile.prn").Close
' reactivate alerts
Application.DisplayAlerts = True
End Function
This function starts by moving the new FinalFormat sheet and moves it to its own workboook.
...
Application.DisplayAlerts = False
ActiveSheet.SaveAs Filename:="C:\tmp\tmpBulkFile.prn", FileFormat:=xlTextPrinter
...
The Application.DisplayAlerts operation suppresses any warnings about overwriting a current
file if one already exists.
The file is then closed and reopened as this causes the .prn formatting to comes into play. All data is put into
the cells in column A. The data is split at 240 characters and any characters beyond this count
is put in the cells below where the last cell origonally was.
...
For i = 1 To LastRow
Range("A" & i) = Left(Worksheets("tmpBulkFile").Range("A" & i), 239) & Left(Worksheets("tmpBulkFile").Range("A" & LastRow + i), 36)
Next i
...
Given that this data is spit in this way I am able to grab the two cells and concatinated them. At the same time the trailing "i"'s that were add during the formatting are dropped.
WriteTotxtRemoveQuotation()
This last function creates the txt file that will be submitted, this is is fully formatted and directly submittable with no edits needed.
Function WriteTotxtRemoveQuotation(LastRow)
Dim TempString As String
Workbooks("tmpBulkFile.prn").Activate
Sheets(1).Activate
Open "c:\tmp\SubBulkFile.txt" For Output As #1
For Each Row In Range("A1:A" & LastRow)
TempString = ""
For Each Cell In Row.Cells
TempString = TempString & Cell.Text & Chr(9)
Next c
'Get rid of trailing tabs
While Right(TempString, 1) = Chr(9)
TempString = Left(TempString, Len(TempString) - 1)
Wend
...
Print #1, TempString
...
Next Row
Close #1
End Function
First a txt file is opened as #1 because the print statement in VBA expects a filenumber
between 1-255.
Here another querk of the .prn file format type is taken care of. It will for some reason add tabs (Chr(9))
at the end of some of the cell strings.
...
Dim TempString As String
...
While Right(TempString, 1) = Chr(9)
TempString = Left(TempString, Len(TempString) - 1)
Wend
...
First the value of the cell is stored, then while the the last character of the cell value is a tab, the last character is removed.
...
Print #1, TempString
...
The last operation done for each cell is to print the new cell value without the tabs to the txt file.
Summary
Website Theme
Socials
