7
\$\begingroup\$

This is the next step in my project to query Companies House records. The first step, retrieving and validating the company numbers to be targeted, was covered here and I will include that code at the end for context.


In this stage, GetTargetFilenames, I need to parse the entire series of Corporate Filings (typically 100,000 per month, going back 30 months at this point) and, for each:

  • Extract the company number from the filename
  • Check the company number against the ones I am targeting
  • If it is being targeted, add it to a Dictionary of target filenames

With this project, I am trying to take particular care with regards to future maintainability (naming, commenting etc.), so any critiques of that aspect would be especially welcome.


Option Explicit

Public Const COMPANY_NUMBER_COLUMN As Long = 1
Public Const parentFolderPath As String = "S:\Investments\Data\Companies House\Monthly Companies House Downloads\"

Public Sub ParseAllCompanyRecords()
    '/ Data Structure: "Company Numbers", once input, will be stored as strings
    '/ Company Number: 8-character string, generally 8-digits but sometimes with text prefixes E.G. "OC374102"

    '/ Folder Path for monthly CH downloads: "S:\Investments\Data\Companies House\Monthly Companies House Downloads\"
    '/ Filename Strucutre of a Monthly Folder: [parentFolderPath]"Accounts_Monthly_Data-"[Full Month Name][yyyy]"\" - Square Brackets not in filename
    '/ Filename Structure of an individual filing: [Monthly Folder Path]"Prod224_"[4-character code]"_"[8-character Company Registration Number]"_"[yyyymmdd][.html OR .xml] - Square Brackets not in filename

    Dim targetCompanyNumbers As Dictionary
    Set targetCompanyNumbers = GetTargetCompanyNumbers

    Dim targetFilenames As Dictionary
    Set targetFilenames = GetTargetFilenames(targetCompanyNumbers)

End Sub

Public Function GetTargetFilenames(ByRef targetCompanyNumbers As Dictionary) As Dictionary
    '/ Folder Path for monthly CH downloads: "S:\Investments\Data\Companies House\Monthly Companies House Downloads\"
    '/ Filename Strucutre of a Monthly Folder: [parentFolderPath]"Accounts_Monthly_Data-"[Full Month Name][yyyy]"\" - Square Brackets not in filename
    '/ Filename Structure of an individual filing: [Monthly Folder Path]"Prod224_"[4-character code]"_"[8-character Company Registration Number]"_"[yyyymmdd][.html OR .xml] - Square Brackets not in filename

    Dim targetFilenames As Dictionary
    Set targetFilenames = New Dictionary

    Const START_YEAR As Long = 2013
    Const START_MONTH As Long = 9 '/ September

    Dim iYear As Long
    iYear = START_YEAR

    Dim iMonth As Long
    iMonth = START_MONTH

    Dim currentYear As Long
    currentYear = Year(Now)

    Dim currentMonth As Long
    currentMonth = Month(Now)

    Dim monthFolderPath As String
    Dim fileSpec As String
    Dim fileList As Collection

    Dim filename As String
    Dim companyNumber As String
    Dim isTarget As Boolean

    Dim i As Long

    Do While Not ((iYear = currentYear And iMonth > currentMonth) Or iYear > currentYear) '/ first condition will not catch where current Month is December, hence second condition

        DoEvents '/ These folders are BIG, like 100,000 - 300,000 files and 5-15GB EACH big, so this may take a while and DoEvents is necessary
        '/ Expected runtime, 30s-2m per month folder, typically 40s
        Debug.Print "Year: " & iYear & " Month: " & iMonth & " Begin folder parse: " & Format(Now, "hh:mm:ss")

        monthFolderPath = FolderPathFromMonthYear(iMonth, iYear)

        fileSpec = monthFolderPath & "*"
        Set fileList = GetFileList(fileSpec)

        DoEvents
        Debug.Print "Year: " & iYear & " Month: " & iMonth & " Filelist Retrieved: " & Format(Now, "hh:mm:ss")

        For i = 1 To fileList.Count
            If i Mod 8192 = 0 Then DoEvents
            filename = fileList(i)
            companyNumber = CompanyNumberFromFilename(filename)
            isTarget = targetCompanyNumbers.Exists(companyNumber)
            If isTarget And Not targetFilenames.Exists(filename) Then targetFilenames.Add filename, filename
        Next i

        DoEvents
        Debug.Print "Year: " & iYear & " Month: " & iMonth & " End MonthLoop: " & Format(Now, "hh:mm:ss")

        iMonth = iMonth + 1
        If iMonth = 13 Then
            iYear = iYear + 1
            iMonth = iMonth - 12
        End If
    Loop

    Set GetTargetFilenames = targetFilenames

End Function

Public Function FolderPathFromMonthYear(iMonth, iYear) As String
    '/ Folder Path for monthly CH downloads: "S:\Investments\Data\Companies House\Monthly Companies House Downloads\"
    '/ Filename Strucutre of a Monthly Folder: [parentFolderPath]"Accounts_Monthly_Data-"[Full Month Name][yyyy]"\" - Square Brackets not in filename

    FolderPathFromMonthYear = parentFolderPath & "Accounts_Monthly_Data-" & MonthName(iMonth) & CStr(iYear) & "\"

End Function

Public Function CompanyNumberFromFilename(ByVal filename As String) As String
    '/ Company Number: 8-character string, generally 8-digits but sometimes with text prefixes E.G. "OC374102"
    '/ Filename Structure of an individual filing: [Monthly Folder Path]"Prod224_"[4-character code]"_"[8-character Company Registration Number]"_"[yyyymmdd][.html OR .xml] - Square Brackets not in filename

    '/ Can only guarantee the structure of the final fileName section of the filePath, so will work from the end of the filename backwards
    Dim indexFinalFullStop As Long
    indexFinalFullStop = InStrRev(filename, ".") '/ returns final full stop in string

    '/ End of filename structure: [8-character target number]"_"[yyyymmdd]"."[file extension]
    '/ targetnumber starts 17 characters before the final full stop
    Dim indexCompanyNumber As Long
    indexCompanyNumber = indexFinalFullStop - 17

    Dim companyNumber As String
    companyNumber = Mid$(filename, indexCompanyNumber, 8)

    CompanyNumberFromFilename = companyNumber

End Function

Function GetFileList(fileSpec As String) As Collection

    Dim fileList As Collection
    Set fileList = New Collection

    Dim fullFilename As String
    fullFilename = Dir(fileSpec)

    Do While fullFilename <> ""
        fileList.Add fullFilename
        fullFilename = Dir()
    Loop

    Set GetFileList = fileList

End Function

GetTargetCompanyNumbers

provided for context if desired:

Public Function GetTargetCompanyNumbers() As Dictionary

    Dim targetCompanyNumbers As Dictionary
    Set targetCompanyNumbers = New Dictionary

    Dim finalRow As Long, columnRange As Range
    With wsInputs
        finalRow = .Cells(.Rows.Count, COMPANY_NUMBER_COLUMN).End(xlUp).row
        Set columnRange = .Range(.Cells(2, COMPANY_NUMBER_COLUMN), .Cells(finalRow, COMPANY_NUMBER_COLUMN))
    End With

    Dim columnArray As Variant
    columnArray = columnRange

    Dim LB1 As Long, UB1 As Long
    AssignArrayBounds columnArray, LB1, UB1

    Dim ix As Long
    Dim elementValue As Variant
    Dim companyNumber As String

    For ix = LB1 To UB1
        elementValue = columnArray(ix, 1)
        companyNumber = CompanyNumberFromValue(elementValue)
        If Not (targetCompanyNumbers.Exists(companyNumber) Or companyNumber = vbNullString) Then targetCompanyNumbers.Add companyNumber, companyNumber
    Next ix

    Set GetTargetCompanyNumbers = targetCompanyNumbers

End Function

Public Function CompanyNumberFromValue(ByVal vValue As Variant) As String
    '/ Company Number: 8-character string, generally 8-digits but sometimes with text prefixes E.G. "OC374102"

    Dim textValue As String
    textValue = CStr(vValue)

    Dim trimText As String
    trimText = Trim$(textValue)

    Dim companyNumber As String

    If IsNumeric(trimText) Then
        companyNumber = Format(trimText, "00000000") '/ Add back any leading zeroes that Excel may have stripped
    ElseIf Len(trimText) = 8 Then
        companyNumber = trimText
    Else
        '/ Not a number, not the correct number of characters. Invalid input.
        companyNumber = vbNullString
    End If

    CompanyNumberFromValue = companyNumber

End Function
\$\endgroup\$
  • \$\begingroup\$ My assumption is that inStrRev should be faster? I find the documentation not clear in that it will return the same number as inStr - not the index number starting from the back. That could end up in confusion for someone. \$\endgroup\$ – Raystafarian Apr 21 '16 at 16:55
  • \$\begingroup\$ @Raystafarian not quite. InStrRev will start at the end of the string and return the first match it finds. InStr will do the same but from the start of the string. So, they will only be the same number if there is only one match in the string to find. MCVE here \$\endgroup\$ – Kaz Apr 21 '16 at 17:17
  • \$\begingroup\$ Blocked by my work's firewall. Like I said, the documentation is unclear. So if there's only one . in a file name, it might be better to use instr, but if there's not then there's really no way around it. \$\endgroup\$ – Raystafarian Apr 21 '16 at 17:21
  • \$\begingroup\$ A) I want the full stop at the end of the filename, so InStrRev is going to be faster anyway and B) Using "." in folder names is perfectly valid in Windows, so I can't assume that there won't be any \$\endgroup\$ – Kaz Apr 21 '16 at 17:23
3
\$\begingroup\$

To improve the performance, you should list the files in an Array instead of a Collection. I would also drop the unnecessary * for the file expression:

Sub GetFileList(folder As String, outList() As String)
    Dim fname$, count&
    ReDim outList(0 To 10000)  ' set initial array size

    fname = FileSystem.Dir(folder, vbNormal)
    Do While Len(fname)

        ' double the size of the array if necessary
        If count > UBound(outList) Then ReDim Preserve outList(0 To UBound(outList) * 2)

        ' insert the file path
        outList(count) = fname
        count = count + 1

        ' next file
        fname = FileSystem.Dir()
    Loop

    ' set the final size for the array
    If count Then
      ReDim Preserve outList(0 To count - 1)
    Else
      outList = Split(Empty)  ' set an empty array
    End If
End Sub

Public Function GetTargetFilenames(ByRef targetCompanyNumbers As Dictionary) As Dictionary
    ...

    Dim fileList() As String
    GetFileList monthFolderPath, fileList

    For i = LBound(fileList) To UBound(fileList)
        ...
    Next

End Function
\$\endgroup\$
  • \$\begingroup\$ Good points and wow, I haven't seen type hints in a looong time. \$\endgroup\$ – Kaz May 5 '16 at 8:09
2
\$\begingroup\$

Everything looks pretty solid.

Dim fileSpec as String

I think this could be named better - I'm not sure what it is unless it's specifications?


Do While Not ((iYear = currentYear And iMonth > currentMonth) Or (iYear > currentYear))

I'd add the extra set of parenthesis just to make it more clear that it says not this or not this rather than not this or is that


Changing the iteration of iMonth to sit inside the if will save you one line of code. Also why subtract 12 from a known 13, just put it back at 1.

    If iMonth = 12 Then
        iYear = iYear + 1
        iMonth = 1
    Else: iMonth = iMonth + 1

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.