no image

Code for Excel statistics spreadsheet

Privacy Level: Public (Green)
Date: 25 Jan 2024
Profile manager: Roy Walmsley private message [send private message]
This page has been accessed 83 times.

Introduction

This page contains a snapshot of the Excel VBA coding that is used in the following spreadsheet, outputting text that can be pasted into the corresponding FSPs. The code is common to all of the spreadsheets, and it's performance is set up by a) the settings in the "Control" worksheet, and b) the text in the "Text" worksheet.

Excel Spreadsheet FSP page FSP Status
England Unknowns Statistics.xlsm England Unknowns Live, Adopted by the England Project
England Unconnected Statistics.xlsm England Unconnected Live
England Unlinked Statistics.xlsm England Unlinked Live
Wales Unknowns Statistics.xlsm Wales Unknowns Live

Code

Sub InitialiseImport() Dim controlWS As Worksheet Dim currentWB As Workbook Dim masterWS As Worksheet Dim numMasterColumns As Long Dim numMasterRows As Long Dim numUpdateColumns As Long Dim numUpdateRows As Long Dim response As Integer Dim sheetName As String Dim sheetsFound As Integer Dim updateWS As Worksheet ' Get the necessary worksheets Set currentWB = ActiveWorkbook sheetsFound = 0 For i = 1 To currentWB.Sheets.Count sheetName = currentWB.Sheets(i).Name If (sheetName = "Profiles Master") Then Set masterWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "Profiles Update") Then Set updateWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "Control") Then Set controlWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 End If Next If (sheetsFound < 3) Then response = MsgBox("Missing Worksheets: Execution Terminated", vbOKOnly, "Initialise : Error") Exit Sub End If ' Find the number of rows and columns used in the master and update sheets numMasterRows = masterWS.UsedRange.Rows.Count numMasterColumns = masterWS.UsedRange.Columns.Count numUpdateRows = updateWS.UsedRange.Rows.Count numUpdateColumns = updateWS.UsedRange.Columns.Count If (numUpdateColumns <> numMasterColumns) Then response = MsgBox("Master and Update sheets have different numbers of columns: Execution Terminated", vbOKOnly, "Initialise : Error") Exit Sub End If ' If there are profiles in the update sheet, clear the master, and move the profiles from the update to the master If (numUpdateRows > 1) Then response = MsgBox("Do you want to move all profiles on the Profiles Update sheet to the Profiles Master sheet, overwriting any existing profiles?", vbYesNoCancel, "Initialise : Warning") If (response = vbCancel) Then Exit Sub ElseIf (response = vbYes) Then If (numMasterRows > 1) Then masterWS.Range("A2", masterWS.Range("A1").Offset(numMasterRows - 1, numMasterColumns - 1)).ClearContents End If updateWS.Range("A2", updateWS.Range("A1").Offset(numUpdateRows - 1, numUpdateColumns - 1)).Cut masterWS.Range("A2") End If End If ' Reset control sheet values controlWS.Range("E2").Value = 0 controlWS.Range("H2").Value = 0 controlWS.Range("I2").Value = 0 End Sub Sub GenerateReport() Dim controlWS As Worksheet Dim currentWB As Workbook Dim sheetName As String Dim sheetsFound As Integer Dim URLStr As String ' Get the necessary worksheets Set currentWB = ActiveWorkbook sheetsFound = 0 For i = 1 To currentWB.Sheets.Count sheetName = currentWB.Sheets(i).Name If (sheetName = "Control") Then Set controlWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 End If Next If (sheetsFound < 1) Then response = MsgBox("Missing Worksheets: Execution Terminated", vbOKOnly, "Generate Report : Error") Exit Sub End If ' Call the URL to WikiTree+ to download a page of profiles to the Excel spreadsheet URLStr = controlWS.Range("F2").Value ActiveWorkbook.FollowHyperlink Address:=URLStr, NewWindow:=True End Sub Function ExtractCounty(location As String, country As String) As String Dim county As String If (location = "") Then county = "" ElseIf (location = country) Then county = "Unknown County" ElseIf (Left(location, Len(country) + 1) = (country & " ")) Then county = Right(location, Len(location) - (Len(country) + 1)) Else county = "Other Country" End If ExtractCounty = county End Function Sub ImportResults() ' ' Import Data Macro ' Imports the results from a partial WikiTree report ' ' Dim controlWS As Worksheet Dim currentWB As Workbook Dim fileNameStr As String Dim folderNameStr As String Dim i As Integer Dim numColumns As Long Dim numRows As Long Dim reportWB As Workbook Dim reportWS As Worksheet Dim startRow As Long Dim updateWS As Worksheet ' Get the necessary worksheets Set currentWB = ActiveWorkbook sheetsFound = 0 For i = 1 To currentWB.Sheets.Count sheetName = currentWB.Sheets(i).Name If (sheetName = "Control") Then Set controlWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "Profiles Update") Then Set updateWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 End If Next If (sheetsFound < 2) Then response = MsgBox("Missing Worksheets: Execution Terminated", vbOKOnly, "Import Results : Error") Exit Sub End If ' Read data from control sheet folderNameStr = controlWS.Range("J2").Value fileNameStr = folderNameStr + controlWS.Range("K2").Value + ".xlsx" startRow = controlWS.Range("I2").Value ' Open the report workbook Set reportWB = Workbooks.Open(fileNameStr) Set reportWS = reportWB.Sheets(1) ' Get the number of rows and columns numRows = reportWS.UsedRange.Rows.Count numColumns = reportWS.UsedRange.Columns.Count ' If this is the first partial report run then copy the headings If (startRow = 0) Then reportWS.Range("A1", Range("A1").Offset(, numColumns)).Select Selection.Copy updateWS.Activate updateWS.Range("A1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False End If ' Accumulate the report data into the results sheet reportWS.Activate reportWS.Range("A2", Range("A2").Offset(numRows - 2, numColumns)).Select Selection.Copy updateWS.Activate updateWS.Range("A" + CStr(startRow + 2)).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False 'Tidy up and report summary reportWB.Close controlWS.Activate controlWS.Range("H2").Value = numRows - 1 controlWS.Range("I2").Value = startRow + numRows - 1 'Increment Page Index controlWS.Range("E2").Value = controlWS.Range("E2").Value + 1 End Sub Sub GenerateStatistics() Dim addedCountiesWS As Worksheet Dim addedWS As Worksheet Dim birthCounty As String Dim currentWB As Workbook Dim controlWS As Worksheet Dim countiesCounts() As Long Dim countiesNames() As String Dim country As String Dim county As String Dim deathCounty As String Dim folderPath As String Dim i As Long Dim j As Long Dim marriageCounty As String Dim masterRow As Long Dim masterUserID As Long Dim masterWS As Worksheet Dim numAdded As Long Dim numColumns As Long Dim numMasterColumns As Long Dim numMasterRows As Long Dim numRefCounties As Long Dim numRemoved As Long Dim numRows As Long Dim numUpdateColumns As Long Dim numUpdateRows As Long Dim outputFileName As String Dim removedCountiesWS As Worksheet Dim removedWS As Worksheet Dim response As Integer Dim sheetName As String Dim sheetsFound As Integer Dim total As Long Dim unknownsOutputWB As Workbook Dim updateRow As Long Dim updateUserID As Long Dim updateWS As Worksheet ' Get all required worksheets folderPath = Application.ActiveWorkbook.Path Set currentWB = ActiveWorkbook sheetsFound = 0 For i = 1 To currentWB.Sheets.Count sheetName = currentWB.Sheets(i).Name If (sheetName = "Profiles Master") Then Set masterWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "Profiles Update") Then Set updateWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "Profiles Added") Then Set addedWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "Profiles Removed") Then Set removedWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "Control") Then Set controlWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "Added Counties") Then Set addedCountiesWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "Removed Counties") Then Set removedCountiesWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 End If Next If (sheetsFound < 7) Then response = MsgBox("Missing Worksheets: Execution Terminated", vbOKOnly, "Generate Statistics : Error") Exit Sub End If ' Get the country country = controlWS.Range("A6").Value ' Find the number of rows and columns used in the master and update sheets numMasterRows = masterWS.UsedRange.Rows.Count numMasterColumns = masterWS.UsedRange.Columns.Count numUpdateRows = updateWS.UsedRange.Rows.Count numUpdateColumns = updateWS.UsedRange.Columns.Count If (numUpdateColumns <> numMasterColumns) Then response = MsgBox("Master and Update sheets have different numbers of columns: Execution Terminated", vbOKOnly, "Generate Statistics : Error") Exit Sub End If ' Sort the update sheets by UserID (column A) updateWS.Range("A1", updateWS.Range("A1").Offset(numUpdateRows - 1, numUpdateColumns - 1)).Sort Key1:=updateWS.Range("A1"), Order1:=xlAscending, Header:=xlYes ' Clear the profiles from the Profiles Added and Profiles Removed sheets numRows = addedWS.UsedRange.Rows.Count numColumns = addedWS.UsedRange.Columns.Count addedWS.Range("A2", addedWS.Range("A1").Offset(numRows - 1, numColumns - 1)).ClearContents numRows = removedWS.UsedRange.Rows.Count numColumns = removedWS.UsedRange.Columns.Count removedWS.Range("A2", removedWS.Range("A1").Offset(numRows - 1, numColumns - 1)).ClearContents ' Loop through the master / update sheets to find profiles in one but not the other masterRow = 2 updateRow = 2 numRemoved = 0 numAdded = 0 While ((masterRow <= numMasterRows) Or (updateRow <= numUpdateRows)) masterUserID = masterWS.Range("A" + CStr(masterRow)).Value updateUserID = updateWS.Range("A" + CStr(updateRow)).Value If (masterUserID = 0) Then masterUserID = 2147483647 If (updateUserID = 0) Then updateUserID = 2147483647 If (masterUserID = updateUserID) Then masterRow = masterRow + 1 updateRow = updateRow + 1 ElseIf ((masterRow > numMasterRows) Or (masterUserID > updateUserID)) Then updateWS.Range("A" + CStr(updateRow), updateWS.Range("A" + CStr(updateRow)).Offset(, numUpdateColumns)).Copy addedWS.Range("A" + CStr(numAdded + 2)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False numAdded = numAdded + 1 updateRow = updateRow + 1 ElseIf ((updateRow > numUpdateRows) Or (masterUserID < updateUserID)) Then masterWS.Range("A" + CStr(masterRow), masterWS.Range("A" + CStr(masterRow)).Offset(, numMasterColumns)).Copy removedWS.Range("A" + CStr(numRemoved + 2)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False numRemoved = numRemoved + 1 masterRow = masterRow + 1 Else response = MsgBox("Unexpected error comparing master and update sheets: Execution Terminated", vbOKOnly, "Generate Statistics : Error") Exit Sub End If Wend ' Clear the profiles, county names, and counts, from the Added Counties and Removed Counties sheets numRows = addedCountiesWS.UsedRange.Rows.Count numColumns = 6 addedCountiesWS.Range("A2", addedCountiesWS.Range("A1").Offset(numRows - 1, numColumns - 1)).ClearContents numRows = removedCountiesWS.UsedRange.Rows.Count numColumns = 6 removedCountiesWS.Range("A2", removedCountiesWS.Range("A1").Offset(numRows - 1, numColumns - 1)).ClearContents ' Extract county for removed profiles for birth, death, and marriage For i = 1 To numRemoved county = ExtractCounty(Trim(removedWS.Range("H" + CStr(i + 1)).Value), country) removedCountiesWS.Range("A" + CStr(i + 1)).Value = county county = ExtractCounty(Trim(removedWS.Range("O" + CStr(i + 1)).Value), country) removedCountiesWS.Range("B" + CStr(i + 1)).Value = county county = ExtractCounty(Trim(removedWS.Range("AB" + CStr(i + 1)).Value), country) removedCountiesWS.Range("C" + CStr(i + 1)).Value = county Next ' Count the number of reference counties numRefCounties = 0 i = 1 While (controlWS.Range("A" + CStr(i + 30)).Value <> "") numRefCounties = numRefCounties + 1 i = i + 1 Wend ReDim countiesNames(1 To numRefCounties) ReDim countiesCounts(numRefCounties) ' Copy the reference county list to the Removed Counties sheet controlWS.Range("A31", controlWS.Range("A31").Offset(numRefCounties - 1)).Copy removedCountiesWS.Range("E2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' Initialise for counting For i = 1 To numRefCounties countiesCounts(i) = 0 countiesNames(i) = removedCountiesWS.Range("E" + CStr(i + 1)).Value Next ' Count number of profiles that each county in reference list appears in For i = 1 To numRemoved birthCounty = removedCountiesWS.Range("A" + CStr(i + 1)).Value If (birthCounty <> "") Then For j = 2 To numRefCounties If (InStr(birthCounty, countiesNames(j))) Then countiesCounts(j) = countiesCounts(j) + 1 j = numRefCounties End If Next End If deathCounty = removedCountiesWS.Range("B" + CStr(i + 1)).Value If ((deathCounty <> "") And (deathCounty <> birthCounty)) Then For j = 2 To numRefCounties If (InStr(deathCounty, countiesNames(j))) Then countiesCounts(j) = countiesCounts(j) + 1 j = numRefCounties End If Next End If marriageCounty = removedCountiesWS.Range("C" + CStr(i + 1)).Value If ((marriageCounty <> "") And (marriageCounty <> birthCounty) And (marriageCounty <> deathCounty)) Then For j = 2 To numRefCounties If (marriageCounty = countiesNames(j)) Then countiesCounts(j) = countiesCounts(j) + 1 j = numRefCounties End If Next End If Next countiesCounts(1) = numRemoved For i = 1 To numRefCounties removedCountiesWS.Range("F" + CStr(i + 1)).Value = countiesCounts(i) Next removedCountiesWS.Range("E" + CStr(numRefCounties + 3)).Value = "Total" total = 0 For i = 2 To numRefCounties total = total + countiesCounts(i) Next removedCountiesWS.Range("F" + CStr(numRefCounties + 3)).Value = total ' Extract county for added profiles for birth, death, and marriage For i = 1 To numAdded county = ExtractCounty(Trim(addedWS.Range("H" + CStr(i + 1)).Value), country) addedCountiesWS.Range("A" + CStr(i + 1)).Value = county county = ExtractCounty(Trim(addedWS.Range("O" + CStr(i + 1)).Value), country) addedCountiesWS.Range("B" + CStr(i + 1)).Value = county county = ExtractCounty(Trim(addedWS.Range("AB" + CStr(i + 1)).Value), country) addedCountiesWS.Range("C" + CStr(i + 1)).Value = county Next ' Copy the reference county list to the Added Counties sheet controlWS.Range("A31", controlWS.Range("A31").Offset(numRefCounties - 1)).Copy addedCountiesWS.Range("E2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' Count number of profiles that each county in reference list appears in For i = 1 To numRefCounties countiesCounts(i) = 0 Next For i = 1 To numAdded birthCounty = addedCountiesWS.Range("A" + CStr(i + 1)).Value If (birthCounty <> "") Then For j = 2 To numRefCounties If (InStr(birthCounty, countiesNames(j))) Then countiesCounts(j) = countiesCounts(j) + 1 j = numRefCounties End If Next End If deathCounty = addedCountiesWS.Range("B" + CStr(i + 1)).Value If ((deathCounty <> "") And (deathCounty <> birthCounty)) Then For j = 2 To numRefCounties If (InStr(deathCounty, countiesNames(j))) Then countiesCounts(j) = countiesCounts(j) + 1 j = numRefCounties End If Next End If marriageCounty = addedCountiesWS.Range("C" + CStr(i + 1)).Value If ((marriageCounty <> "") And (marriageCounty <> birthCounty) And (marriageCounty <> deathCounty)) Then For j = 2 To numRefCounties If (marriageCounty = countiesNames(j)) Then countiesCounts(j) = countiesCounts(j) + 1 j = numRefCounties End If Next End If Next countiesCounts(1) = numAdded For i = 1 To numRefCounties addedCountiesWS.Range("F" + CStr(i + 1)).Value = countiesCounts(i) Next addedCountiesWS.Range("E" + CStr(numRefCounties + 3)).Value = "Total" total = 0 For i = 2 To numRefCounties total = total + countiesCounts(i) Next addedCountiesWS.Range("F" + CStr(numRefCounties + 3)).Value = total ' Create a new workbook and put results in, finally save to a CSV file outputFileName = controlWS.Range("K6").Value Set unknownsOutputWB = Workbooks.Add currentWB.Activate addedCountiesWS.Range("F2", addedCountiesWS.Range("F2").Offset(numRefCounties - 1)).Copy unknownsOutputWB.Activate Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False currentWB.Activate removedCountiesWS.Range("F2", removedCountiesWS.Range("F2").Offset(numRefCounties - 1)).Copy unknownsOutputWB.Activate Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False unknownsOutputWB.SaveAs fileName:=folderPath + "\" + outputFileName, FileFormat:=xlCSV unknownsOutputWB.Close End Sub Sub CountChecking() Dim birthCounty As String Dim controlWS As Worksheet Dim countiesNames() As String Dim countiesCounts() As Long Dim countiesWS As Worksheet Dim country As String Dim currentWB As Workbook Dim deathCounty As String Dim fileName As String Dim folderPath As String Dim i As Long Dim iRow As Long Dim letterCode As Integer Dim marriageCounty As String Dim numColumns As Long Dim numProfiles As Long Dim numRefCounties As Long Dim numRows As Long Dim numUpdateColumns As Long Dim numUpdateRows As Long Dim sheetsFound As Integer Dim total As Long Dim updateCountiesWS As Worksheet Dim updateWS As Worksheet Dim updateCounty As String Dim wrentWB As Workbook Dim wrentWS As Worksheet ' Get all required worksheets Set currentWB = ActiveWorkbook sheetsFound = 0 For i = 1 To currentWB.Sheets.Count sheetName = currentWB.Sheets(i).Name If (sheetName = "Profiles Update") Then Set updateWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "County Breakdown") Then Set countiesWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "Update Counties") Then Set updateCountiesWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "Control") Then Set controlWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 End If Next If (sheetsFound < 4) Then response = MsgBox("Missing Worksheets: Execution Terminated", vbOKOnly, "County Breakdown : Error") Exit Sub End If ' Get the country country = controlWS.Range("A6").Value ' Find the number of rows and columns used in the update sheet numUpdateRows = updateWS.UsedRange.Rows.Count numUpdateColumns = updateWS.UsedRange.Columns.Count ' Clear the profiles, reference county list, and counts, from the Update Counties sheets numRows = updateCountiesWS.UsedRange.Rows.Count numColumns = 6 updateCountiesWS.Range("A2", updateCountiesWS.Range("A1").Offset(numRows - 1, numColumns - 1)).ClearContents ' Extract county for removed profiles for birth, death, and marriage numProfiles = numUpdateRows - 1 For i = 1 To numProfiles county = ExtractCounty(Trim(updateWS.Range("H" + CStr(i + 1)).Value), country) updateCountiesWS.Range("A" + CStr(i + 1)).Value = county county = ExtractCounty(Trim(updateWS.Range("O" + CStr(i + 1)).Value), country) updateCountiesWS.Range("B" + CStr(i + 1)).Value = county county = ExtractCounty(Trim(updateWS.Range("AB" + CStr(i + 1)).Value), country) updateCountiesWS.Range("C" + CStr(i + 1)).Value = county Next ' Count the number of reference counties numRefCounties = 0 i = 1 While (controlWS.Range("A" + CStr(i + 30)).Value <> "") numRefCounties = numRefCounties + 1 i = i + 1 Wend ReDim countiesNames(1 To numRefCounties) ReDim countiesCounts(1 To numRefCounties) ' Copy the reference county list to the Update Counties sheet controlWS.Range("A31", controlWS.Range("A31").Offset(numRefCounties - 1)).Copy updateCountiesWS.Range("E2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' Initialise for counting For i = 1 To numRefCounties countiesCounts(i) = 0 countiesNames(i) = updateCountiesWS.Range("E" + CStr(i + 1)).Value Next ' Count number of profiles that each county in reference list appears in For i = 1 To numProfiles birthCounty = updateCountiesWS.Range("A" + CStr(i + 1)).Value If (birthCounty <> "") Then For j = 2 To numRefCounties If (InStr(birthCounty, countiesNames(j))) Then countiesCounts(j) = countiesCounts(j) + 1 j = numRefCounties End If Next End If deathCounty = updateCountiesWS.Range("B" + CStr(i + 1)).Value If ((deathCounty <> "") And (deathCounty <> birthCounty)) Then For j = 2 To numRefCounties If (InStr(deathCounty, countiesNames(j))) Then countiesCounts(j) = countiesCounts(j) + 1 j = numRefCounties End If Next End If marriageCounty = updateCountiesWS.Range("C" + CStr(i + 1)).Value If ((marriageCounty <> "") And (marriageCounty <> birthCounty) And (marriageCounty <> deathCounty)) Then letterCode = Asc(marriageCounty) For j = 2 To numRefCounties If (marriageCounty = countiesNames(j)) Then countiesCounts(j) = countiesCounts(j) + 1 j = numRefCounties End If Next End If Next countiesCounts(1) = numProfiles For i = 1 To numRefCounties updateCountiesWS.Range("F" + CStr(i + 1)).Value = countiesCounts(i) Next updateCountiesWS.Range("E" + CStr(numRefCounties + 3)).Value = "Total" total = 0 For i = 2 To numRefCounties total = total + countiesCounts(i) Next updateCountiesWS.Range("F" + CStr(numRefCounties + 3)).Value = total ' Read data from control sheet folderPath = Application.ActiveWorkbook.Path fileName = folderPath + "\" + controlWS.Range("K20").Value ' Open the WRENT output csv file Set wrentWB = Workbooks.Open(fileName) Set wrentWS = wrentWB.Sheets(1) ' Copy the WRENT values in wrentWB.Activate wrentWS.Range("A1", wrentWS.Range("A1").Offset(numRefCounties - 1)).Copy currentWB.Activate updateCountiesWS.Range("G2", updateCountiesWS.Range("G2").Offset(numRefCounties - 1)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False ' Close the WRENT output csv file wrentWB.Close End Sub Sub CountyBreakdown() Dim addedWS As Worksheet Dim backgroundColour As String Dim birthCentury As Integer Dim birthCounty As String Dim centuryIndex As Integer Dim controlWS As Worksheet Dim countArray3D() As Long Dim countiesFlags() As String Dim countiesNames() As String Dim countiesWS As Worksheet Dim country As String Dim countyName As String Dim currentWB As Workbook Dim deathCounty As String Dim firstCountyNumberInRegions() As Integer Dim folderPath As String Dim i As Integer Dim iCounty As Integer Dim iProfile As Long Dim iRegion As Integer Dim j As Integer Dim k As Integer Dim managed As Boolean Dim managedString As String Dim marriageCounty As String Dim maxCountiesPerRegion As Integer Dim notOpen As Boolean Dim orphaned As Boolean Dim orphanedString As String Dim numCountiesInRegions() As Integer Dim numNewProfiles As Long Dim numProfiles As Long Dim numRefCounties As Integer Dim numRefRegions As Integer Dim numSolvedProfiles As Long Dim regionMapImageFileNames() As String Dim regionName As String Dim regionNames() As String Dim removedWS As Worksheet Dim reviewedEP As Boolean Dim rowStart As Integer Dim sheetName As String Dim sheetsFound As Integer Dim teamPageURLs() As String Dim textWS As Worksheet Dim updateWS As Worksheet Dim countiesDisplayNames() As String Dim chapmanCodes() As String Dim chapmanDisplayOrderCodes() As String Dim displayOrder() As Integer 'Variables specific to WikiTree+ queries Dim birthFullQueryElement As String Dim birthLocationQueryElement As String Dim century15QueryElement As String Dim century16QueryElement As String Dim century17QueryElement As String Dim century18QueryElement As String Dim century19QueryElement As String Dim century20QueryElement As String Dim centuryQueryElements(8) As String Dim combinedQueryElement As String Dim countiesQueryNames() As String Dim countryQueryElement As String Dim deathFullQueryElement As String Dim deathLocationQueryElement As String Dim managedQueryElement As String Dim marriageFullQueryElement As String Dim marriageLocationQueryElement As String Dim noDateQueryElement As String Dim notOpenQueryElement As String Dim orphanedQueryElement As String Dim reviewedQueryElement As String Dim unknownQueryElement As String Dim wikitreePlusBaseURL As String Dim wikiTreePlusOptions As String Dim wikiTreePlusURL As String 'Get all required worksheets folderPath = Application.ActiveWorkbook.Path Set currentWB = ActiveWorkbook sheetsFound = 0 For i = 1 To currentWB.Sheets.Count sheetName = currentWB.Sheets(i).Name If (sheetName = "Profiles Update") Then Set updateWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "County Breakdown") Then Set countiesWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "Control") Then Set controlWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "Profiles Added") Then Set addedWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "Profiles Removed") Then Set removedWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 ElseIf (sheetName = "Text") Then Set textWS = currentWB.Sheets(i) sheetsFound = sheetsFound + 1 End If Next If (sheetsFound < 6) Then response = MsgBox("Missing Worksheets: Execution Terminated", vbOKOnly, "County Breakdown : Error") Exit Sub End If ' Get the country country = controlWS.Range("A6").Value 'Get the reference county and region details numRefCounties = 0 numRefRegions = 0 i = 31 ' First row of reference county list on Control sheet While (controlWS.Range("A" + CStr(i)).Value <> "") numRefCounties = numRefCounties + 1 If (controlWS.Range("B" + CStr(i)).Value <> "") Then numRefRegions = numRefRegions + 1 End If i = i + 1 Wend ' Set up all the arrays, and load the reference county names ReDim regionNames(1 To numRefRegions) ReDim regionMapImageFileNames(1 To numRefRegions) ReDim firstCountyNumberInRegions(1 To numRefRegions) ReDim numCountiesInRegions(1 To numRefRegions) ReDim teamPageURLs(1 To numRefCounties) ReDim countiesFlags(1 To numRefCounties) ReDim countiesNames(1 To numRefCounties) ReDim countiesQueryNames(1 To numRefCounties) ReDim countiesDisplayNames(1 To numRefCounties) ReDim chapmanCodes(1 To numRefCounties) ReDim chapmanDisplayOrderCodes(1 To numRefCounties) For i = 1 To numRefCounties countiesNames(i) = controlWS.Range("A" + CStr(i + 30)).Value countiesQueryNames(i) = controlWS.Range("G" + CStr(i + 30)).Value countiesDisplayNames(i) = controlWS.Range("H" + CStr(i + 30)).Value If (countiesDisplayNames(i) = "") Then countiesDisplayNames(i) = countiesNames(i) End If chapmanCodes(i) = controlWS.Range("E" + CStr(i + 30)).Value chapmanDisplayOrderCodes(i) = controlWS.Range("I" + CStr(i + 30)).Value Next ' Set up display mapping order ReDim displayOrder(1 To numRefCounties) For i = 1 To numRefCounties If (chapmanCodes(i) = chapmanDisplayOrderCodes(i)) Then displayOrder(i) = i Else displayOrder(i) = -1 For j = 1 To numRefCounties If (chapmanCodes(j) = chapmanDisplayOrderCodes(i)) Then displayOrder(i) = j End If Next End If If (displayOrder(i)) = -1 Then response = MsgBox("Display Order Code " + chapmanDisplayOrderCodes(i) + " not recognized: Execution Terminated", vbOKOnly, "County Breakdown : Error") Exit Sub End If Next ' Load all the region and county specific reference data iRegion = 0 For iCounty = 1 To numRefCounties regionName = controlWS.Range("B" + CStr(30 + iCounty)).Value If (regionName <> "") Then iRegion = iRegion + 1 regionNames(iRegion) = regionName regionMapImageFileNames(iRegion) = controlWS.Range("C" + CStr(30 + iCounty)).Value firstCountyNumberInRegions(iRegion) = iCounty numCountiesInRegions(iRegion) = 1 Else numCountiesInRegions(iRegion) = numCountiesInRegions(iRegion) + 1 End If teamPageURLs(iCounty) = controlWS.Range("D" + CStr(30 + iCounty)).Value countiesFlags(iCounty) = controlWS.Range("F" + CStr(30 + iCounty)).Value Next maxCountiesPerRegion = 0 For iRegion = 1 To numRefRegions If (numCountiesInRegions(iRegion) > maxCountiesPerRegion) Then maxCountiesPerRegion = numCountiesInRegions(iRegion) End If Next ' Find the number of profiles numProfiles = updateWS.UsedRange.Rows.Count - 1 ' Initialise the counts array ReDim countArray3D(1 To numRefCounties, 1 To 10, 1 To 5) For i = 1 To numRefCounties For j = 1 To 9 For k = 1 To 5 countArray3D(i, j, k) = 0 Next Next Next 'Start of the main loop for all counties 'Loop to find profiles belonging to the county For iProfile = 1 To numProfiles birthCounty = ExtractCounty(Trim(updateWS.Range("H" + CStr(iProfile + 1)).Value), country) deathCounty = ExtractCounty(Trim(updateWS.Range("O" + CStr(iProfile + 1)).Value), country) marriageCounty = ExtractCounty(Trim(updateWS.Range("AB" + CStr(iProfile + 1)).Value), country) 'ToDo - Extract multiple marriage counties and include them in the check below birthCentury = updateWS.Range("K" + CStr(iProfile + 1)).Value centuryIndex = 0 Select Case birthCentury Case 1 To 15 centuryIndex = 2 Case 16 To 19 centuryIndex = birthCentury - 13 Case 20 To 21 centuryIndex = 7 Case Else centuryIndex = 1 End Select managedString = updateWS.Range("U" + CStr(iProfile + 1)).Value managed = managedString <> "" orphanedString = updateWS.Range("V" + CStr(iProfile + 1)).Value orphaned = InStr(orphanedString, "Orphan") notOpen = updateWS.Range("Q" + CStr(iProfile + 1)).Value <> "Open" reviewedEP = InStr(updateWS.Range("S" + CStr(iProfile + 1)).Value, country & "_Project,_Unknown_Reviewed") 'Increment the appropriate counters for the whole county If (managed And Not (notOpen Or reviewedEP Or orphaned)) Then countArray3D(1, centuryIndex, 1) = countArray3D(1, centuryIndex, 1) + 1 countArray3D(1, 8, 1) = countArray3D(1, 8, 1) + 1 'Row total End If If (orphaned And Not reviewedEP) Then countArray3D(1, centuryIndex, 2) = countArray3D(1, centuryIndex, 2) + 1 countArray3D(1, 8, 2) = countArray3D(1, 8, 2) + 1 'Row total End If If (notOpen) Then countArray3D(1, centuryIndex, 3) = countArray3D(1, centuryIndex, 3) + 1 countArray3D(1, 8, 3) = countArray3D(1, 8, 3) + 1 'Row total End If If (reviewedEP) Then countArray3D(1, centuryIndex, 4) = countArray3D(1, centuryIndex, 4) + 1 countArray3D(1, 8, 4) = countArray3D(1, 8, 4) + 1 'Row total End If countArray3D(1, centuryIndex, 5) = countArray3D(1, centuryIndex, 5) + 1 ' Column Total countArray3D(1, 8, 5) = countArray3D(1, 8, 5) + 1 'Row total For iCounty = 2 To numRefCounties countyName = countiesNames(iCounty) If (InStr(birthCounty, countyName) Or InStr(deathCounty, countyName) Or (marriageCounty = countyName)) Then ' Increment the appropriate counters If (managed And Not (notOpen Or reviewedEP Or orphaned)) Then countArray3D(iCounty, centuryIndex, 1) = countArray3D(iCounty, centuryIndex, 1) + 1 countArray3D(iCounty, 8, 1) = countArray3D(iCounty, 8, 1) + 1 'Row total End If If (orphaned And Not reviewedEP) Then countArray3D(iCounty, centuryIndex, 2) = countArray3D(iCounty, centuryIndex, 2) + 1 countArray3D(iCounty, 8, 2) = countArray3D(iCounty, 8, 2) + 1 'Row total End If If (notOpen) Then countArray3D(iCounty, centuryIndex, 3) = countArray3D(iCounty, centuryIndex, 3) + 1 countArray3D(iCounty, 8, 3) = countArray3D(iCounty, 8, 3) + 1 'Row total End If If (reviewedEP) Then countArray3D(iCounty, centuryIndex, 4) = countArray3D(iCounty, centuryIndex, 4) + 1 countArray3D(iCounty, 8, 4) = countArray3D(iCounty, 8, 4) + 1 'Row total End If countArray3D(iCounty, centuryIndex, 5) = countArray3D(iCounty, centuryIndex, 5) + 1 ' Column Total countArray3D(iCounty, 8, 5) = countArray3D(iCounty, 8, 5) + 1 'Row total End If Next Next ' Find the number of new profiles numNewProfiles = addedWS.UsedRange.Rows.Count - 1 'Start of the main loop for all counties 'Loop to find profiles belonging to the county For iProfile = 1 To numNewProfiles birthCounty = ExtractCounty(Trim(addedWS.Range("H" + CStr(iProfile + 1)).Value), country) deathCounty = ExtractCounty(Trim(addedWS.Range("O" + CStr(iProfile + 1)).Value), country) marriageCounty = ExtractCounty(Trim(addedWS.Range("AB" + CStr(iProfile + 1)).Value), country) managedString = addedWS.Range("U" + CStr(iProfile + 1)).Value managed = managedString <> "" orphanedString = addedWS.Range("V" + CStr(iProfile + 1)).Value orphaned = InStr(orphanedString, "Orphan") notOpen = addedWS.Range("Q" + CStr(iProfile + 1)).Value <> "Open" reviewedEP = InStr(addedWS.Range("S" + CStr(iProfile + 1)).Value, country & " Project, Unknown Reviewed") If (managed And Not (notOpen Or reviewedEP Or orphaned)) Then countArray3D(1, 9, 1) = countArray3D(1, 9, 1) + 1 End If If (orphaned And Not reviewedEP) Then countArray3D(1, 9, 2) = countArray3D(1, 9, 2) + 1 End If If (notOpen) Then countArray3D(1, 9, 3) = countArray3D(1, 9, 3) + 1 End If If (reviewedEP) Then countArray3D(1, 9, 4) = countArray3D(1, 9, 4) + 1 End If countArray3D(1, 9, 5) = countArray3D(1, 9, 5) + 1 ' Column Total 'ToDo - Extract multiple marriage counties and include them in the check below For iCounty = 2 To numRefCounties countyName = countiesNames(iCounty) If (InStr(birthCounty, countyName) Or InStr(deathCounty, countyName) Or (marriageCounty = countyName)) Then ' Increment the appropriate counters If (managed And Not (notOpen Or reviewedEP Or orphaned)) Then countArray3D(iCounty, 9, 1) = countArray3D(iCounty, 9, 1) + 1 End If If (orphaned And Not reviewedEP) Then countArray3D(iCounty, 9, 2) = countArray3D(iCounty, 9, 2) + 1 End If If (notOpen) Then countArray3D(iCounty, 9, 3) = countArray3D(iCounty, 9, 3) + 1 End If If (reviewedEP) Then countArray3D(iCounty, 9, 4) = countArray3D(iCounty, 9, 4) + 1 End If countArray3D(iCounty, 9, 5) = countArray3D(iCounty, 9, 5) + 1 ' Column Total End If Next Next ' Find the number of new profiles numSolvedProfiles = removedWS.UsedRange.Rows.Count - 1 'Start of the main loop for all counties (except all of the country) 'Loop to find profiles belonging to the county For iProfile = 1 To numSolvedProfiles birthCounty = ExtractCounty(Trim(removedWS.Range("H" + CStr(iProfile + 1)).Value), country) deathCounty = ExtractCounty(Trim(removedWS.Range("O" + CStr(iProfile + 1)).Value), country) marriageCounty = ExtractCounty(Trim(removedWS.Range("AB" + CStr(iProfile + 1)).Value), country) managedString = removedWS.Range("U" + CStr(iProfile + 1)).Value managed = managedString <> "" orphanedString = removedWS.Range("V" + CStr(iProfile + 1)).Value orphaned = InStr(orphanedString, "Orphan") notOpen = removedWS.Range("Q" + CStr(iProfile + 1)).Value <> "Open" reviewedEP = InStr(removedWS.Range("S" + CStr(iProfile + 1)).Value, country & " Project, Unknown Reviewed") If (managed And Not (notOpen Or reviewedEP Or orphaned)) Then countArray3D(1, 10, 1) = countArray3D(1, 10, 1) + 1 End If If (orphaned And Not reviewedEP) Then countArray3D(1, 10, 2) = countArray3D(1, 10, 2) + 1 End If If (notOpen) Then countArray3D(1, 10, 3) = countArray3D(1, 10, 3) + 1 End If If (reviewedEP) Then countArray3D(1, 10, 4) = countArray3D(1, 10, 4) + 1 End If countArray3D(1, 10, 5) = countArray3D(1, 10, 5) + 1 ' Column Total 'ToDo - Extract multiple marriage counties and include them in the check below For iCounty = 2 To numRefCounties countyName = countiesNames(iCounty) If (InStr(birthCounty, countyName) Or InStr(deathCounty, countyName) Or (marriageCounty = countyName)) Then ' Increment the appropriate counters If (managed And Not (notOpen Or reviewedEP Or orphaned)) Then countArray3D(iCounty, 10, 1) = countArray3D(iCounty, 10, 1) + 1 End If If (orphaned And Not reviewedEP) Then countArray3D(iCounty, 10, 2) = countArray3D(iCounty, 10, 2) + 1 End If If (notOpen) Then countArray3D(iCounty, 10, 3) = countArray3D(iCounty, 10, 3) + 1 End If If (reviewedEP) Then countArray3D(iCounty, 10, 4) = countArray3D(iCounty, 10, 4) + 1 End If countArray3D(iCounty, 10, 5) = countArray3D(iCounty, 10, 5) + 1 ' Column Total End If Next Next 'Output the results to the County Breakdown sheet For iCounty = 1 To numRefCounties rowStart = iCounty * 7 - 4 countiesWS.Range("A" + CStr(rowStart)).Value = countiesNames(iCounty) countiesWS.Range("B" + CStr(rowStart)).Value = "No date" countiesWS.Range("C" + CStr(rowStart)).Value = "Pre 1500" countiesWS.Range("D" + CStr(rowStart)).Value = "1500-1599" countiesWS.Range("E" + CStr(rowStart)).Value = "1600-1699" countiesWS.Range("F" + CStr(rowStart)).Value = "1700-1799" countiesWS.Range("G" + CStr(rowStart)).Value = "1800-1899" countiesWS.Range("H" + CStr(rowStart)).Value = "1900 Onwards" countiesWS.Range("I" + CStr(rowStart)).Value = "Total" countiesWS.Range("J" + CStr(rowStart)).Value = "New" countiesWS.Range("K" + CStr(rowStart)).Value = "Solved" countiesWS.Range("A" + CStr(rowStart + 1)).Value = "Managed" countiesWS.Range("B" + CStr(rowStart + 1)).Value = countArray3D(iCounty, 1, 1) countiesWS.Range("C" + CStr(rowStart + 1)).Value = countArray3D(iCounty, 2, 1) countiesWS.Range("D" + CStr(rowStart + 1)).Value = countArray3D(iCounty, 3, 1) countiesWS.Range("E" + CStr(rowStart + 1)).Value = countArray3D(iCounty, 4, 1) countiesWS.Range("F" + CStr(rowStart + 1)).Value = countArray3D(iCounty, 5, 1) countiesWS.Range("G" + CStr(rowStart + 1)).Value = countArray3D(iCounty, 6, 1) countiesWS.Range("H" + CStr(rowStart + 1)).Value = countArray3D(iCounty, 7, 1) countiesWS.Range("I" + CStr(rowStart + 1)).Value = countArray3D(iCounty, 8, 1) countiesWS.Range("J" + CStr(rowStart + 1)).Value = countArray3D(iCounty, 9, 1) countiesWS.Range("K" + CStr(rowStart + 1)).Value = countArray3D(iCounty, 10, 1) countiesWS.Range("A" + CStr(rowStart + 2)).Value = "Orphaned" countiesWS.Range("B" + CStr(rowStart + 2)).Value = countArray3D(iCounty, 1, 2) countiesWS.Range("C" + CStr(rowStart + 2)).Value = countArray3D(iCounty, 2, 2) countiesWS.Range("D" + CStr(rowStart + 2)).Value = countArray3D(iCounty, 3, 2) countiesWS.Range("E" + CStr(rowStart + 2)).Value = countArray3D(iCounty, 4, 2) countiesWS.Range("F" + CStr(rowStart + 2)).Value = countArray3D(iCounty, 5, 2) countiesWS.Range("G" + CStr(rowStart + 2)).Value = countArray3D(iCounty, 6, 2) countiesWS.Range("H" + CStr(rowStart + 2)).Value = countArray3D(iCounty, 7, 2) countiesWS.Range("I" + CStr(rowStart + 2)).Value = countArray3D(iCounty, 8, 2) countiesWS.Range("J" + CStr(rowStart + 2)).Value = countArray3D(iCounty, 9, 2) countiesWS.Range("K" + CStr(rowStart + 2)).Value = countArray3D(iCounty, 10, 2) countiesWS.Range("A" + CStr(rowStart + 3)).Value = "Not Open" countiesWS.Range("B" + CStr(rowStart + 3)).Value = countArray3D(iCounty, 1, 3) countiesWS.Range("C" + CStr(rowStart + 3)).Value = countArray3D(iCounty, 2, 3) countiesWS.Range("D" + CStr(rowStart + 3)).Value = countArray3D(iCounty, 3, 3) countiesWS.Range("E" + CStr(rowStart + 3)).Value = countArray3D(iCounty, 4, 3) countiesWS.Range("F" + CStr(rowStart + 3)).Value = countArray3D(iCounty, 5, 3) countiesWS.Range("G" + CStr(rowStart + 3)).Value = countArray3D(iCounty, 6, 3) countiesWS.Range("H" + CStr(rowStart + 3)).Value = countArray3D(iCounty, 7, 3) countiesWS.Range("I" + CStr(rowStart + 3)).Value = countArray3D(iCounty, 8, 3) countiesWS.Range("J" + CStr(rowStart + 3)).Value = countArray3D(iCounty, 9, 3) countiesWS.Range("K" + CStr(rowStart + 3)).Value = countArray3D(iCounty, 10, 3) countiesWS.Range("A" + CStr(rowStart + 4)).Value = "EP Reviewed" countiesWS.Range("B" + CStr(rowStart + 4)).Value = countArray3D(iCounty, 1, 4) countiesWS.Range("C" + CStr(rowStart + 4)).Value = countArray3D(iCounty, 2, 4) countiesWS.Range("D" + CStr(rowStart + 4)).Value = countArray3D(iCounty, 3, 4) countiesWS.Range("E" + CStr(rowStart + 4)).Value = countArray3D(iCounty, 4, 4) countiesWS.Range("F" + CStr(rowStart + 4)).Value = countArray3D(iCounty, 5, 4) countiesWS.Range("G" + CStr(rowStart + 4)).Value = countArray3D(iCounty, 6, 4) countiesWS.Range("H" + CStr(rowStart + 4)).Value = countArray3D(iCounty, 7, 4) countiesWS.Range("I" + CStr(rowStart + 4)).Value = countArray3D(iCounty, 8, 4) countiesWS.Range("J" + CStr(rowStart + 4)).Value = countArray3D(iCounty, 9, 4) countiesWS.Range("K" + CStr(rowStart + 4)).Value = countArray3D(iCounty, 10, 4) countiesWS.Range("A" + CStr(rowStart + 5)).Value = "Total" countiesWS.Range("B" + CStr(rowStart + 5)).Value = countArray3D(iCounty, 1, 5) countiesWS.Range("C" + CStr(rowStart + 5)).Value = countArray3D(iCounty, 2, 5) countiesWS.Range("D" + CStr(rowStart + 5)).Value = countArray3D(iCounty, 3, 5) countiesWS.Range("E" + CStr(rowStart + 5)).Value = countArray3D(iCounty, 4, 5) countiesWS.Range("F" + CStr(rowStart + 5)).Value = countArray3D(iCounty, 5, 5) countiesWS.Range("G" + CStr(rowStart + 5)).Value = countArray3D(iCounty, 6, 5) countiesWS.Range("H" + CStr(rowStart + 5)).Value = countArray3D(iCounty, 7, 5) countiesWS.Range("I" + CStr(rowStart + 5)).Value = countArray3D(iCounty, 8, 5) countiesWS.Range("J" + CStr(rowStart + 5)).Value = countArray3D(iCounty, 9, 5) countiesWS.Range("K" + CStr(rowStart + 5)).Value = countArray3D(iCounty, 10, 5) Next 'Now we need to create the text file output that can be copied into a WikiTree FSP Dim textFile As Integer Dim filePath As String Dim textString As String 'ToDo: Change the path to be the same as the current spreadsheet filePath = folderPath + "\" + controlWS.Range("K7").Value textFile = FreeFile Open filePath For Output As textFile 'Add categories and opening links (note that for application to countries other than England the code assumes they are set up the same way) Print #textFile, "[[Category:" & country & ", Project Managed FSPs]]" Print #textFile, "[[Category:" & country & ", Maintenance Categories]]" Print #textFile, "[[:Project:" & country & "|" & country & " Project Page]] | [[:Space:" & country & ":_Counties_Team|" & country & " Counties Team]]" 'Add contents section, starting with disabling automatic contents generation Print #textFile, "__NOTOC__" Print #textFile, "== Contents ==" Print #textFile, "'''GENERAL'''<br/>" Print #textFile, "* [[#Introduction|Introduction]]" Print #textFile, "* [[#Process|Process]]" Print #textFile, "* [[#Quick_Links|Quick Links]]" Print #textFile, "'''DATA'''<br/>" Print #textFile, "* [[#" & country & "|" & country & "]]<br/>" Print #textFile, "* [[#Unknown_County|" & country & " Unknown County]]<br/>" Print #textFile, "* Regions and Counties" Print #textFile, "{| border=""1"" cellPadding=""4""" textString = "!" For iRegion = 2 To numRefRegions textString = textString + "[[#" + SpaceToUnderline(regionNames(iRegion)) + "|" + SpaceToBreakTag(regionNames(iRegion)) + "]]" If (iRegion < numRefRegions) Then textString = textString + "!!" End If Next Print #textFile, textString For i = 1 To maxCountiesPerRegion Print #textFile, "|-" textString = "|" For iRegion = 2 To numRefRegions If (i > numCountiesInRegions(iRegion)) Then textString = textString + " " Else iCounty = displayOrder(firstCountyNumberInRegions(iRegion) + i - 1) countyName = countiesDisplayNames(iCounty) textString = textString + "[[#" + SpaceToUnderline(countyName) For j = 2 To numRefRegions If (countyName = regionNames(j)) Then textString = textString + "_2" Exit For End If Next textString = textString + "|" + countyName + "]]" End If If (iRegion < numRefRegions) Then textString = textString + "||" End If Next Print #textFile, textString Next Print #textFile, "|}" Print #textFile, "" Print #textFile, "" 'Write the headings and introductory text Print #textFile, "== Introduction ==" Print #textFile, "" Print #textFile, textWS.Range("D7").Value Print #textFile, "" 'Load the WikiTree+ query data wikitreePlusBaseURL = controlWS.Range("B13").Value unknownQueryElement = controlWS.Range("B14").Value countryQueryElement = controlWS.Range("B15").Value reviewedQueryElement = controlWS.Range("B19").Value managedQueryElement = controlWS.Range("B16").Value & reviewedQueryElement orphanedQueryElement = controlWS.Range("B17").Value & reviewedQueryElement notOpenQueryElement = controlWS.Range("B18").Value noDateQueryElement = controlWS.Range("B20").Value century15QueryElement = controlWS.Range("B21").Value century16QueryElement = controlWS.Range("B22").Value century17QueryElement = controlWS.Range("B23").Value century18QueryElement = controlWS.Range("B24").Value century19QueryElement = controlWS.Range("B25").Value century20QueryElement = controlWS.Range("B26").Value wikiTreePlusOptions = controlWS.Range("B28").Value centuryQueryElements(1) = noDateQueryElement centuryQueryElements(2) = century15QueryElement centuryQueryElements(3) = century16QueryElement centuryQueryElements(4) = century17QueryElement centuryQueryElements(5) = century18QueryElement centuryQueryElements(6) = century19QueryElement centuryQueryElements(7) = century20QueryElement centuryQueryElements(8) = "" 'Main loop to add the tables - done by region, and then county For iRegion = 1 To numRefRegions If (iRegion > 1) Then Print #textFile, "== " + regionNames(iRegion) + " ==" Print #textFile, "" Print #textFile, "{{Image|file=" + regionMapImageFileNames(iRegion) Print #textFile, "|align=l" Print #textFile, "|size=s" Print #textFile, "}}" Print #textFile, "{{Clear}}" Print #textFile, "" End If For i = 1 To numCountiesInRegions(iRegion) iCounty = displayOrder(firstCountyNumberInRegions(iRegion) + i - 1) countyName = countiesDisplayNames(iCounty) If (iCounty = 2) Then backgroundColour = """#d6e9c9""" Else backgroundColour = """#e0f0ff""" End If If (iCounty = 1 Or iCounty = 2) Then Print #textFile, "== " + countyName + " ==" Else Print #textFile, "=== " + countyName + " ===" End If Print #textFile, "" If (iCounty = 1) Then Print #textFile, textWS.Range("D9").Value ElseIf (iCounty = 2) Then Print #textFile, textWS.Range("D11").Value Else textString = textWS.Range("D13").Value Print #textFile, Replace(textString, "__COUNTY__", countyName, 1, -1, vbTextCompare) End If Print #textFile, "" Print #textFile, "{| border=""1"" cellpadding=""6"" bgcolor=" + backgroundColour Print #textFile, "|-" textString = "| align=""center""| " If (teamPageURLs(iCounty) <> "") Then textString = textString + "[[" + teamPageURLs(iCounty) + "|'''" + UCase(countyName) + "''']]" Else textString = textString + "'''" + UCase(countyName) + "'''" End If Print #textFile, textString Print #textFile, "|-" Print #textFile, "|" Print #textFile, "{| border=""1"" cellpadding=""6"" bgcolor=""#ffffff""" Print #textFile, "|-" textString = "| " If (countiesFlags(iCounty) <> "") Then textString = textString & "{{Image|File=" & countiesFlags(iCounty) & "|align=c|size=s}}" & vbCrLf End If textString = textString & " || No date || Pre 1500 || 1500-1599 || 1600-1699 || 1700-1799 || 1800-1899 || 1900 Onwards || Total || New || Solved" Print #textFile, textString If (iCounty = 1) Then birthLocationQueryElement = "birthCountry%3D" & country deathLocationQueryElement = "deathCountry%3D" & country marriageLocationQueryElement = "marriageCountry%3D" & country Else birthLocationQueryElement = "birthCountry%3D" & country & "+birthRegion%3D" & countiesQueryNames(iCounty) deathLocationQueryElement = "deathCountry%3D" & country & "+deathRegion%3D" & countiesQueryNames(iCounty) marriageLocationQueryElement = "marriageCountry%3D" & country & "+marriageRegion%3D" & countiesQueryNames(iCounty) End If Print #textFile, "|-" textString = "| Managed" For j = 1 To 8 If (centuryQueryElements(j) = "") Then birthFullQueryElement = unknownQueryElement & "+" & birthLocationQueryElement & "+" & managedQueryElement deathFullQueryElement = unknownQueryElement & "+" & deathLocationQueryElement & "+" & managedQueryElement marriageFullQueryElement = unknownQueryElement & "+" & marriageLocationQueryElement & "+" & managedQueryElement Else If (Left(centuryQueryElements(j), 3) = "not") Then birthFullQueryElement = unknownQueryElement & "+" & birthLocationQueryElement & "+" & managedQueryElement & "+" & centuryQueryElements(j) deathFullQueryElement = unknownQueryElement & "+" & deathLocationQueryElement & "+" & managedQueryElement & "+" & centuryQueryElements(j) marriageFullQueryElement = unknownQueryElement & "+" & marriageLocationQueryElement & "+" & managedQueryElement & "+" & centuryQueryElements(j) Else birthFullQueryElement = unknownQueryElement & "+" & birthLocationQueryElement & "+" & centuryQueryElements(j) & "+" & managedQueryElement deathFullQueryElement = unknownQueryElement & "+" & deathLocationQueryElement & "+" & centuryQueryElements(j) & "+" & managedQueryElement marriageFullQueryElement = unknownQueryElement & "+" & marriageLocationQueryElement & "+" & centuryQueryElements(j) & "+" & managedQueryElement End If End If combinedQueryElement = birthFullQueryElement & "+or+" & deathFullQueryElement & "+or+" & marriageFullQueryElement wikiTreePlusURL = wikitreePlusBaseURL & "Query=" & combinedQueryElement & "&" & wikiTreePlusOptions textString = textString & " || [" & wikiTreePlusURL & " " & CStr(countArray3D(iCounty, j, 1)) & "]" Next textString = textString & " || " & CStr(countArray3D(iCounty, 9, 1)) textString = textString & " || " & CStr(countArray3D(iCounty, 10, 1)) Print #textFile, textString Print #textFile, "|-" textString = "| Orphaned" For j = 1 To 8 If (centuryQueryElements(j) = "") Then birthFullQueryElement = unknownQueryElement & "+" & birthLocationQueryElement & "+" & orphanedQueryElement deathFullQueryElement = unknownQueryElement & "+" & deathLocationQueryElement & "+" & orphanedQueryElement marriageFullQueryElement = unknownQueryElement & "+" & marriageLocationQueryElement & "+" & orphanedQueryElement Else If (Left(centuryQueryElements(j), 3) = "not") Then birthFullQueryElement = unknownQueryElement & "+" & birthLocationQueryElement & "+" & orphanedQueryElement & "+" & centuryQueryElements(j) deathFullQueryElement = unknownQueryElement & "+" & deathLocationQueryElement & "+" & orphanedQueryElement & "+" & centuryQueryElements(j) marriageFullQueryElement = unknownQueryElement & "+" & marriageLocationQueryElement & "+" & orphanedQueryElement & "+" & centuryQueryElements(j) Else birthFullQueryElement = unknownQueryElement & "+" & birthLocationQueryElement & "+" & centuryQueryElements(j) & "+" & orphanedQueryElement deathFullQueryElement = unknownQueryElement & "+" & deathLocationQueryElement & "+" & centuryQueryElements(j) & "+" & orphanedQueryElement marriageFullQueryElement = unknownQueryElement & "+" & marriageLocationQueryElement & "+" & centuryQueryElements(j) & "+" & orphanedQueryElement End If End If combinedQueryElement = birthFullQueryElement & "+or+" & deathFullQueryElement & "+or+" & marriageFullQueryElement wikiTreePlusURL = wikitreePlusBaseURL & "Query=" & combinedQueryElement & "&" & wikiTreePlusOptions textString = textString & " || [" & wikiTreePlusURL & " " & CStr(countArray3D(iCounty, j, 2)) & "]" Next textString = textString & " || " & CStr(countArray3D(iCounty, 9, 2)) textString = textString & " || " & CStr(countArray3D(iCounty, 10, 2)) Print #textFile, textString Print #textFile, "|-" textString = "| Not Open" For j = 1 To 8 If (centuryQueryElements(j) = "") Then birthFullQueryElement = unknownQueryElement & "+" & birthLocationQueryElement & "+" & notOpenQueryElement deathFullQueryElement = unknownQueryElement & "+" & deathLocationQueryElement & "+" & notOpenQueryElement marriageFullQueryElement = unknownQueryElement & "+" & marriageLocationQueryElement & "+" & notOpenQueryElement Else birthFullQueryElement = unknownQueryElement & "+" & birthLocationQueryElement & "+" & centuryQueryElements(j) & "+" & notOpenQueryElement deathFullQueryElement = unknownQueryElement & "+" & deathLocationQueryElement & "+" & centuryQueryElements(j) & "+" & notOpenQueryElement marriageFullQueryElement = unknownQueryElement & "+" & marriageLocationQueryElement & "+" & centuryQueryElements(j) & "+" & notOpenQueryElement End If combinedQueryElement = birthFullQueryElement & "+or+" & deathFullQueryElement & "+or+" & marriageFullQueryElement wikiTreePlusURL = wikitreePlusBaseURL & "Query=" & combinedQueryElement & "&" & wikiTreePlusOptions textString = textString & " || [" & wikiTreePlusURL & " " & CStr(countArray3D(iCounty, j, 3)) & "]" Next textString = textString & " || " & CStr(countArray3D(iCounty, 9, 3)) textString = textString & " || " & CStr(countArray3D(iCounty, 10, 3)) Print #textFile, textString Print #textFile, "|-" textString = "| Reviewed" For j = 1 To 8 If (centuryQueryElements(j) = "") Then birthFullQueryElement = unknownQueryElement & "+" & birthLocationQueryElement & "+" & reviewedQueryElement deathFullQueryElement = unknownQueryElement & "+" & deathLocationQueryElement & "+" & reviewedQueryElement marriageFullQueryElement = unknownQueryElement & "+" & marriageLocationQueryElement & "+" & reviewedQueryElement Else birthFullQueryElement = unknownQueryElement & "+" & birthLocationQueryElement & "+" & reviewedQueryElement & "+" & centuryQueryElements(j) deathFullQueryElement = unknownQueryElement & "+" & deathLocationQueryElement & "+" & reviewedQueryElement & "+" & centuryQueryElements(j) marriageFullQueryElement = unknownQueryElement & "+" & marriageLocationQueryElement & "+" & reviewedQueryElement & "+" & centuryQueryElements(j) End If combinedQueryElement = birthFullQueryElement & "+or+" & deathFullQueryElement & "+or+" & marriageFullQueryElement wikiTreePlusURL = wikitreePlusBaseURL & "Query=" & combinedQueryElement & "&" & wikiTreePlusOptions textString = textString & " || [" & wikiTreePlusURL & " " & CStr(countArray3D(iCounty, j, 4)) & "]" Next textString = textString & " || " & CStr(countArray3D(iCounty, 9, 4)) textString = textString & " || " & CStr(countArray3D(iCounty, 10, 4)) Print #textFile, textString Print #textFile, "|-" textString = "| Total" For j = 1 To 8 If (centuryQueryElements(j) = "") Then birthFullQueryElement = unknownQueryElement & "+" & birthLocationQueryElement deathFullQueryElement = unknownQueryElement & "+" & deathLocationQueryElement marriageFullQueryElement = unknownQueryElement & "+" & marriageLocationQueryElement Else birthFullQueryElement = unknownQueryElement & "+" & birthLocationQueryElement & "+" & centuryQueryElements(j) deathFullQueryElement = unknownQueryElement & "+" & deathLocationQueryElement & "+" & centuryQueryElements(j) marriageFullQueryElement = unknownQueryElement & "+" & marriageLocationQueryElement & "+" & centuryQueryElements(j) End If combinedQueryElement = birthFullQueryElement & "+or+" & deathFullQueryElement & "+or+" & marriageFullQueryElement wikiTreePlusURL = wikitreePlusBaseURL & "Query=" & combinedQueryElement & "&" & wikiTreePlusOptions textString = textString & " || [" & wikiTreePlusURL & " " & CStr(countArray3D(iCounty, j, 5)) & "]" Next textString = textString & " || " & CStr(countArray3D(iCounty, 9, 5)) textString = textString & " || " & CStr(countArray3D(iCounty, 10, 5)) Print #textFile, textString Print #textFile, "|}" Print #textFile, "|}" Print #textFile, "" Print #textFile, "" Print #textFile, "[[#Contents|Back to top of page]]" Print #textFile, "" Next Next Print #textFile, "" Print #textFile, "== Process ==" Print #textFile, "" Print #textFile, textWS.Range("D15").Value Print #textFile, "" Print #textFile, "[[#Contents|Back to top of page]]" Print #textFile, "" Print #textFile, "== Quick Links ==" Print #textFile, "" Print #textFile, textWS.Range("D17").Value Print #textFile, "" Print #textFile, "[[#Contents|Back to top of page]]" Print #textFile, "" 'Save & Close Text File Close textFile End Sub Function SpaceToUnderline(str As String) As String Dim i As Integer Dim modString As String modString = "" For i = 1 To Len(str) If (Mid(str, i, 1) = " ") Then modString = modString + "_" Else modString = modString + Mid(str, i, 1) End If Next SpaceToUnderline = modString End Function Function SpaceToBreakTag(str As String) As String Dim i As Integer Dim modString As String modString = "" For i = 1 To Len(str) If (Mid(str, i, 1) = " ") Then modString = modString + "<br/>" Else modString = modString + Mid(str, i, 1) End If Next SpaceToBreakTag = modString End Function





Collaboration


Comments

Leave a message for others who see this profile.
There are no comments yet.
Login to post a comment.