VBA Code
Access it using the worksheet.ListIbjects property
Dim mytable As ListObject
mytable.DataBodyRange - the cells containing the actual data (excluding header & insert row)
mytable.HeaderRowRange
mytable.ShowAutoFilter
mytable.ShowTables
mytables.TotalsRowRange
Usually the simplest way to extract data from a database is by means of the MS Query program.
This can be launched from (Data > Get External Data > New Database Query).
The settings implemented in MS Query can be controlled by the QueryTable object.
In Excel 2000 this object has a lot more properties.
Display the data form
Before you can display the Data Form you must select a cell in the database table first.
Range("B2").Select
Application.ActiveSheet.ShowDataForm
ActiveSheet.ShowDataForm
There are several ways to connect to an external data source
Before you can connect to a database, you must add the appropriate reference to your project.
Languages
Tables
English Arial paried with MS Gothic
English Expert Sans Regular paired with MS Mincho
Ideally want Expert Sans Regular with MS Gothic
Sub cMethodDAO()
Dim strDBFullName As String
Dim dbData As Database, rstWork As Recordset, strSQL As String
strDBFullName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
strSQL = "select distinct [your_field] from dataarea"
'Appropriate driver needed for this statement
Set dbData = OpenDatabase(strDBFullName, False, True, _
Excel8.0;HDR=YES;)
Set rstWork = dbData.OpenRecordset(strSQL)
rstWork.MoveLast
MsgBox rstWork.RecordCount
Set rstWork = Nothing
Set dbData = Nothing
End Sub
where [your_field] is the header of the column you are interested in and
the dataarea is a named area that contains all data in question (could be
the single column you are interested in).
Sub CountUniqueByPivotTable()
On Error GoTo uOut
Application.ScreenUpdating = False
Application.DisplayAlerts = False
TheHeader = ActiveCell.Value
ActiveSheet.PivotTableWizard SourceType:=xlDatabase, _
SourceData:=ActiveSheet.Name & "!" & _
Selection.Address, TableDestination:="", TableName:="uPivotTable"
ActiveSheet.PivotTables("uPivotTable").AddFields RowFields:=TheHeader
ActiveSheet.PivotTables("uPivotTable").PivotFields(TheHeader). _
Orientation = xlDataField
MsgBox Application.WorksheetFunction.CountA(Range("a:a")) - 3
ActiveSheet.Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
uOut:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Although not tested extensively, it appears that the procedure that uses the Collection object produces the fastest result.
Sub cMethodByCollection()
CountUniqueByCollection Selection.Address
End Sub
Sub CountUniqueByCollection(AllCells As String)
Dim NoDupes As New Collection
On Error Resume Next
For Each Cell In Range(AllCells)
NoDupes.Add Cell.Value, CStr(Cell.Value)
'Note: the 2nd argument (key) for the Add method must be a string
Next Cell
On Error GoTo 0
End Sub
Range.Sort Method
Sorts a cell range, pivottable report or the current region if the specified range contains only one cell.
If the Range only contains a single cell then the currentregion is automatically used.
Range("A1:C10").Sort
Worksheets("Sheet1").Range("A1:C10").Sort
Selection.Sort
If no arguments are defined with the Sort method, Microsoft Excel will sort the selection, chosen to be sorted, in ascending order.
Worksheets("DATA").Range("A1:C10").Sort Key1:=Worksheets("DATA").Range("B1"), Order1:=xlDescending, Header:=xlYes
Selection.Sort Key1:=Range("A3"), Order1:=xlSortOrder.xlDescending, _
Key2:=Range("B3"), Order2:=xlSortOrder.xlAscending, _
Key3:=Range("C3"), Order3:=xlSortOrder.xlDescending, _
Header:=xlYesNoGuess.xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlSortOrientation.xlSortRows, _
DataOption1:=xlSortDataOption.xlSortNormal, _
DataOption2:=xlSortDataOption.xlSortTextAsNumbers, _
DataOption3:=xlSortDataOption.xlSortNormal
Key - Specifies the sort field, either as a range name (string) or range object.
Order - Determines the sort order for the values
Header - Specifies whether the first row contains headers.
MatchCase - True to do a case-sensitive sort. False to do a sort that is not case sensitive.
DataOption1 - Specifies how to sort text in Key1. It is necessary to specify xlSortTextAsNumbers when you are using ASCII sorting.
Worksheet Saved Values
The settings for Header, Order1, Order2, Order3, OrderCustom, and Orientation are saved, for the particular worksheet, each time you use this method.
If you don't specify values for these arguments the next time you call the method, the saved values are used.
It is good practice to always explicitly specify all the arguments each time you use the Sort method.
Text Strings
Text strings which are not convertible to numeric data are sorted normally.
Numbers formatted as text ?
Advanced Sorting
Always use the dash "-" as your separator, do not use the underscore as the underscore appears after the numbers/characters when in ASCII order.
Different Worksheet
A different worksheet or a hidden worksheet
Sheet1.Range("A1:B20").Sort Key1:=Sheet1.Range("A2"), Order1:=xlAscending
Sheets("Sheet1").Range(oRange.Address).Sort Key1:=Sheets("Sheet1").Range("A2"),
ActiveSheet.Range("$A$1:$F$182").AutoFilter Field:=2, Criteria1:=Array( _
"Austria", "Finland", "France", "Germany", "Netherlands (The)"), Operator:= _
xlFilterValues
SortFields.Add
Worksheets("DATA").Sort.SortFields.Add (Key, SortOn, Order, CustomOrder, DataOption)
Key - Specifies a key value for the sort.
SortOn - An xlSortOn value that specifies which property of a cell to use for the sort.
Order - An xlSortOrder value that specifies the sort order.
CustomOrder - Specifies if a custom sort order should be used.
DataOption - An xlSortDataOption value that specifies how to sort text.
SortFields.Add2
Added in 2016.
This API includes support for sorting off a SubField from data types, such as Geography or Stocks.
Creates a new sort field and returns a SortFields object that can optionally sort data types with the SubField defined.
Worksheets("DATA").Sort.SortFields.Add2 (Key, SortOn, Order, CustomOrder, DataOption, SubField)
SubField - Specifies the field to sort on for a data type (such as Population for Geography or Volume for Stocks).
This example sorts a table, Table1 on Sheet1, by Column1 in ascending order.
The Clear method is called before to ensure that the previous sort is cleared so that a new one can be applied.
The Sort object is called to apply the added sort to Table1.
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Column1]]"), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal, _
SubField:="Population"
With ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
AutoFilter
If you use the Selection.AutoFilter Filter:=2 then it will reset just column 2, if you use Selection.AutoFilter then it will reset on all columns and will remove the AutoFilter completely.
Worksheets("Data").Select
Worksheets("Data").AutoFilterMode = True
Range("A2").AutoFilter
Range("A2").AutoFilter Field:=3, Criteria1:="filter"
Show all Records
If ActiveSheet.AutoFilter.FilterMode Then
ActiveSheet.AutoFilter.ShowAllData
End If
Toggle on or off
If Not ActiveSheet.AutoFilterMode Then
ActiveSheet.Range("A1").AutoFilter
End If
Remove a filter if it exists
Worksheets("Data").AutoFilterMode = False
ActiveWindow.AutoFilterDateGrouping = Not ActiveWindow.AutoFilterDateGrouping
If ActiveSheet.AutoFilterMode Then
MsgBox "There is a Filter"
Else
MsgBox "There is no Filter"
Selection.AutoFilter
End If
Range("B2").Select
The following line adds the autofilter to the currentregion of the active cell.
ActiveCell.AutoFilter
ActiveCell.AutoFilter Criteria="String"
ActiveCell.AutoFilter Field:=1, Criteria:=">10/07/2004", Operator:=xlAnd, Criteria2:="<16/07/2002"
Range("Database").Select
Removing all existing filters
ActiveSheet.ShowAllData
The above line causes run-time error if filtering is not applied - TEST THIS
On Error Resume Next
ActiveSheet.ShowAllData
Advanced Filter
Copy To Range
Dim rgeCriteria As Range
Dim rgeExtract As Range
Set rgeCriteria = Range("A2:A4")
Set rgeExtract = Range("C2")
Range("B2").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=rgeCriteria, _
CopyToRange:=rgeExtract
Getting a List of Unique Items
Here are four examples of counting unique values in a list. Each of these examples creates an array of the unique items, so they can be modified to to those arrays for a purpose other than just counting the unique items.
Sub cMethodAdvFilter()
CountUniqueByAdvFilter Selection.Address
End Sub
Sub CountUniqueByAdvFilter(mRange As String)
Dim TheRange As String
Application.ScreenUpdating = False
TheRange = "'[" & ActiveWorkbook.Name & _
"]" & ActiveSheet.Name & "'!" & mRange
Workbooks.Add
Range(TheRange).AdvancedFilter Action:=xlFilterCopy, CopyToRange _
:=Range("A1"), Unique:=True
MsgBox Application.WorksheetFunction.CountA(Range("A:A"))
ActiveWorkbook.Close False
Application.ScreenUpdating = True
End Sub
ListObject Object
Represents a list object on a worksheet.
Several ways to update a shared list
1) Refreshing - discards local changes and updates with the data from the server
2) Synchronising - updates both the worksheet list and the server any conflicts can be resolved by the user who is synchronising
objListObject.Refresh
objListObject.UpdateChanges( xlListConflictDialog.xlListConflictError
If the worksheet list is not shated then this method will cause an error.
ListObject(1).Unlist
Creating a List
creates a list around the active cell.
ActiveWorkbook.ListObjects.Add SourceType:=xlScrRange.xlSrcExternal, _
Range("A2:C5"), , xlNo
When SourceType is xlScrExternal, the source argument is a two element array containing the following:
1) The sharepoint list address plus the folder name
2) The name (or GUID) of the list
It is a good idea to create a new workbook when inserting a shared list manually.
SharePoint Lists Web Service to access the list directly though code.
ListObject Collection
The ListObjects collection contains all the list objects on a worksheet.
The ListObjects property can be used to return a read-only collection of ListObject objects in the worksheet.
Use the ListObjects property of the Worksheet can be used to return a ListObjects collection of all the ListObjects on that worksheet.
Dim objWorksheet As Worksheet
Dim objListObject As ListObject
Set objWorksheet = ActiveWorkbook.Worksheets("Sheet1")
If objWorksheet.ListObjects.Count > 0 Then
Set objListObject = objWorksheet.ListObjects(1)
End If
Returns a Range object that represents the range that contains the data area in the list between the header row and the insert row. Read-only.
objListObject.DataBodyRange
True if the specified window, worksheet, or ListObject is displayed from right to left instead of from left to right
False if the object is displayed from left to right. Read-only Boolean
objListObject.DisplayRightToLeft
Returns a Range object that represents the range of the header row for a list. Read-only Range.
objListObject.HeaderRowRange
Returns a ListColumns collection that represents all the columns in a ListObject object. Read-only.
objListObject.ListColumns
Returns a ListRows object that represents all the rows of data in the ListObject object. Read-only.
objListObject.ListRows
Returns or sets the name of the ListObject object.
This name is used solely as a unique identifier for the Item property of the ListObjects collection objects.
This property can only be set through the object model. Read/write String.
By default, each ListObject object name begins with the word "List", followed by a number (no spaces). If an attempt is made to set the Name property to a name already used by another ListObject object, a run-time error is thrown.
objListObject.Name
Returns the QueryTable object that provides a link for the ListObject object to the list server. Read-only.
objListObject.QueryTable
Returns a Range object that represents the range to which the specified list object in the above list applies. Read-Only.
objListObject.Range
Retrieves the current data and schema for the list from the server that is running Microsoft Windows SharePoint Services
This method can be used only with lists that are linked to a SharePoint site.
If the SharePoint site is not available, calling this method will return an error.
Calling the Refresh method does not commit changes to the list in the Excel workbook. Uncommitted changes in the list in Excel are discarded when the Refresh method is called.
To avoid losing any uncommitted changes, call the UpdateChanges method of the ListObject object before calling the Refresh method.
objListObject.Refresh
Resizes the specified range. Returns a Range object that represents the resized range.
objListObject.Resize
Returns a String representing the URL of the SharePoint list for a given ListObject object. Read-only String.
Accessing this property generates a run-time error if the list is not linked to a SharePoint site.
objListObject.SharePointURL
Returns Boolean to indicate whether the AutoFilter will be displayed. Read/write Boolean.
ShowAutoFilter property defaults to True for a new ListObject object.
objListObject.ShowAutoFilter
Gets or sets a Boolean to indicate whether the Total row is visible. Read/write Boolean.
objListObject.ShowTotals
Returns a one of the XlListObjectSourceType constants indicating the current source of the list. Read-only.
objListObject.SourceType
Returns a Range representing the Total row, if any, from a specified ListObject object. Read-only.
objListObject.TotalsRowRange
Updates the list on a Microsoft Windows SharePoint Services site with the changes made to the list in the worksheet. Returns Nothing.
This method applies only to lists linked to a SharePoint site. If the SharePoint site is not available, an error is generated.
Optional XlListConflict. Conflict resolution options.
objListObject.UpdateChanges XlListConflict.xlListConflictError
Returns an XmlMap object that represents the schema map used for the specified list. Read-only.
Note XML features, except for saving files in the XML Spreadsheet format, are available only in Microsoft Office Professional Edition 2003 and Microsoft Office Excel 2003.
objListObject.XmlMap
ListRow Object
Represents a row in a List object. The ListRow object is a member of the ListRows collection.
The ListRows collection contains all the rows in a list object.
Use the ListRows property of the ListObject object to return a ListRows Object collection.
Deletes the cells of the list row and shifts upward any remaining cells below the deleted row. You can delete rows in the list even when the list is linked to a SharePoint site.
The list on the SharePoint site will not be updated, however, until you synchronize your changes.
Dim objListRow As ListRow
objListRow.Delete
ListColumn Object
Represents a column in a list.
The ListColumn object is a member of the ListColumns collection. The ListColumns collection contains all the columns in a list (ListObject object).
Use the ListColumns property of the ListObject object to return a ListColumns collection.
Returns or sets the name of the list column.
This is also used as the display name of the list column. This name must be unique within the list. Read/write String.
Note If this list is linked to a SharePoint list, this property is read-only.
objListColumn.Name
Returns a ListDataFormat object for the ListColumn object. Read-only.
Use the ListDataFormat property to return a ListDataFormat object.
objListColumn.ListDataFormat
Deletes the column of data in the list. Does not remove the column from the sheet.
If the list is linked to a Microsoft Windows SharePoint Services site, the column cannot be removed from the server, and an error is generated.
Dim objListColumn As ListColumn
objListColumn.Delete
Returns a String representing the formula a calculated column.
The formula is expressed in Excel syntax (US English locale, A1 notation). Read-only String.
If the ListColumn object does not belong to a list that is linked to a SharePoint site or if it is not a column designated as a calculated column on the SharePoint site, you will get a run-time error.
objListColumn.SharePointFormula
Determines the type of calculation in the Totals row of the list column based on the value of the XlTotalsCalculation enumeration. Read/write.
The Totals row doesn't need to be showing in order to set this property.
There is no fixed "default" value for this property. Excel may change the state of this property, as other columns are added or deleted.
objListColumn.TotalsCalculation
Returns an XPath object that represents the Xpath of the element mapped to the specified Range object. Read-only.
objListColumn.XPath
Publishing Lists
Publishes the ListObject object to a server that is running Microsoft Windows SharePoint Services.
Returns a String which is the URL of the published list on the SharePoint site
objListObject.Publish(Array("HTTP://MyServer", "MyList", "Description of my list"), True)
Delete Method
Deletes the ListObject object and clears the cell data from the worksheet.
If the list is linked to a SharePoint site, deleting it does not affect data on the server that is running Windows SharePoint Services
Any uncommitted changes made to the local list are not sent to the SharePoint list.
There is no warning that these uncommitted changes are lost.
objListObject.Delete
Unlink Method
Removes the link between the worksheet and the SharePoint server.
Returns Nothing
objListObject.Unlink
To reestablish the link you must delete the list and create it again.
Unlist Method
Convert the list to a regular range preserving the data.
After you use this method, the range of cells that made up the the list will be a regular range of data. Returns Nothing
Removes the list functionality from a ListObject object.
Running this method leaves the cell data, formatting, and formulas in the worksheet. The Total row is also left intact
This method removes any link to a Microsoft Windows SharePoint Services site. AutoFilter and the Insert row are also removed from the list.
objListObject.Unlist
ActiveSheet.ListObjects("myTable").Range.Select
ActiveSheet.ListObjects("myTable").DataBodyRange.Select
ActiveSheet.ListObjects("myTable").DataBodyRange(2, 4).value
ActiveSheet.ListObjects("myTable").ListColumns.Add
ActiveSheet.ListObjects("myTable").ListColumns.Add Position:=2
ActiveSheet.ListObjects("myTable").ListRows.Add
ActiveSheet.ListObjects("myTable").ListRows.Add Position:=1
ActiveSheet.ListObjects("myTable").ListColumns(2).Range.Select
ActiveSheet.ListObjects("myTable").ListColumns("Category").Range.Select
ActiveSheet.ListObjects("myTable").ListColumns(4).DataBodyRange.Select
ActiveSheet.ListObjects("myTable").ListColumns("Category").DataBodyRange.Select
ActiveSheet.ListObjects("myTable").ListColumns.Count
ActiveSheet.ListObjects("myTable").ListColumns("Feb").Delete
ActiveSheet.ListObjects("myTable").Range.Rows("4:6").Delete
ActiveSheet.ListObjects("myTable").HeaderRowRange(5).Select
ActiveSheet.ListObjects("myTable").TotalsRowRange(3).Select
ActiveSheet.ListObjects("myTable").ListRows(3).Range.Select
ActiveSheet.ListObjects("myTable").HeaderRowRange.Select
ActiveSheet.ListObjects("myTable").HeaderRowRange.Select
'when converting a table back to a standard range, the formatting is not removed
ActiveSheet.ListObjects("myTable").Unlist
ActiveSheet.ListObjects("myTable").Resize Range("$A$1:$J$100")
ActiveSheet.ListObjects("myTable").TableStyle = "TableStyleLight15"
ActiveSheet.ListObjects("myTable").ShowTableStyleFirstColumn = True
ActiveSheet.ListObjects("myTable").ShowTableStyleLastColumn = True
ActiveSheet.ListObjects("myTable").ShowTableStyleColumnStripes = True
ActiveSheet.ListObjects("myTable").ShowTableStyleRowStripes = False
ActiveSheet.ListObjects("myTable").ShowHeaders = False
ActiveSheet.ListObjects("myTable").ShowAutoFilterDropDown = False
ActiveWorkbook.DefaultTableStyle = "TableStyleMedium2"
ActiveSheet.Range("myTable[Category]").Select
Dim tableName As String
Dim tableRange As Range
Set tableName = "myTable"
Set tableRange = Selection.CurrentRegion
ActiveSheet.ListObjects.Add(SourceType:=xlSrcRange, _
Source:=tableRange, _
xlListObjectHasHeaders:=xlYes _
).Name = tableName
ActiveSheet.ListObjects("myTable").ShowTotals = True
ActiveSheet.ListObjects("myTable").ListColumns("TotalColumn").TotalsCalculation = xlTotalsCalculationAverage
Dim myArray As Variant
myArray = Range("A2:D2")
'Assign values in array to the table
ActiveSheet.ListObjects("myTable").ListRows(2).Range.Value = myArray
Sub InATable()
Dim ActiveTable As ListObject
On Error Resume Next
Set ActiveTable = ActiveCell.ListObject
On Error GoTo 0
'Confirm if a cell is in a Table
If ActiveTable Is Nothing Then
MsgBox "Select table and try again"
Else
MsgBox "The active cell is in a Table called: " & ActiveTable.Name
End If
End Sub
List Web Service
A SharePoint list can only be removed from the server using SharePoint or by using the List Web Service
If you delete a SharePoint list from the server any worksheet lists that are linked to it will generate an error the next time the list is updated or refreshed.
This provides a direct interface to SharePoint lists on the server.
Lets you perform tasks on the server that you can't perform through Excel such as:
● Add an attachment to a row
Dim lws As New clsws_List
lsw.wsm_AddAttchment
Retrieve an attachment from a row
lsw.wsm_GetAttachmentCollection
Delete an attachment
lsw.wsm_DeleteAttachment
Delete a list
Perform queries
lsw.wsm_GetListItems
results are returned in XML
using an XML query file
VBA - Processing
Dim gvaPositionsPrevious As Variant
Dim gvaPositionsCurrent As Variant
Public Enum enARRAY_ENUM
eKey
eName
eDescription
ePrevious
eCurrent
End Enum
Public Sub Arrays_Processing()
Dim lcount_previous As Long
Dim lcount_current As Long
Dim blast_previous As Boolean
Dim blast_current As Boolean
Dim lrow_output As Long
Dim boutput_previous As Boolean
Dim boutput_current As Boolean
Dim boutput_both As Boolean
On Error GoTo ErrorHandler
gvaPositionsPrevious = Range("PositionsPrevious").Value
gvaPositionsCurrent = Range("PositionsCurrent").Value
lrow_output = 3
lcount_previous = 1
lcount_current = 1
Sheets("Previous vs Current").Select
Range("B3:I5000").ClearContents
With Sheets("Previous vs Current")
Do Until ((blast_previous = True) And (blast_current = True))
boutput_both = False
boutput_current = False
boutput_previous = False
If (blast_previous = True) Then boutput_current = True
If (blast_current = True) Then boutput_previous = True
If ((blast_previous = False) And _
(blast_current = False)) Then
If (gvaPositionsPrevious(lcount_previous, enARRAY_ENUM.eKey) = _
gvaPositionsCurrent(lcount_current, enARRAY_ENUM.eKey)) Then
boutput_both = True
Else
If (gvaPositionsPrevious(lcount_previous, enARRAY_ENUM.eKey) < _
gvaPositionsCurrent(lcount_current, enARRAY_ENUM.eKey)) Then
boutput_previous = True
Else
'therefore Previous > Current, so display Current
boutput_current = True
End If
End If
End If
If (boutput_both = True) Then
.Range("B" & lrow_output).Value = _
gvaPositionsCurrent(lcount_current, enARRAY_ENUM.eName)
.Range("C" & lrow_output).Value = _
gvaPositionsCurrent(lcount_current, enARRAY_ENUM.eDescription)
'display previous
.Range("D" & lrow_output).Value = _
gvaPositionsPrevious(lcount_current, enARRAY_ENUM.ePrevious)
'display current
.Range("E" & lrow_output).Value = _
gvaPositionsCurrent(lcount_current, enARRAY_ENUM.eCurrent)
If (lcount_previous = UBound(gvaPositionsPrevious, 1)) Then
blast_previous = True
End If
If (lcount_previous < UBound(gvaPositionsPrevious, 1)) Then
lcount_previous = lcount_previous + 1
End If
If (lcount_current = UBound(gvaPositionsCurrent, 1)) Then
blast_current = True
End If
If (lcount_current < UBound(gvaPositionsCurrent, 1)) Then
lcount_current = lcount_current + 1
End If
End If
If (boutput_previous = True) Then
.Range("B" & lrow_output).Value = _
gvaPositionsPrevious(lcount_current, enARRAY_ENUM.eName)
.Range("C" & lrow_output).Value = _
gvaPositionsPrevious(lcount_current, enARRAY_ENUM.eDescription)
'display previous
.Range("D" & lrow_output).Value = _
gvaPositionsPrevious(lcount_current, enARRAY_ENUM.ePrevious)
If (lcount_previous = UBound(gvaPositionsPrevious, 1)) Then
blast_previous = True
End If
If (lcount_previous < UBound(gvaPositionsPrevious, 1)) Then
lcount_previous = lcount_previous + 1
End If
End If
If (boutput_current = True) Then
.Range("B" & lrow_output).Value = _
gvaPositionsCurrent(lcount_current, enARRAY_ENUM.eName)
.Range("C" & lrow_output).Value = _
gvaPositionsCurrent(lcount_current, enARRAY_ENUM.eDescription)
'display current
.Range("E" & lrow_output).Value = _
gvaPositionsCurrent(lcount_current, enARRAY_ENUM.eCurrent)
If (lcount_current = UBound(gvaPositionsCurrent, 1)) Then
blast_current = True
End If
If (lcount_current < UBound(gvaPositionsCurrent, 1)) Then
lcount_current = lcount_current + 1
End If
End If
'Difference between current and previous
.Range("F" & lrow_output).FormulaR1C1 = "RC[-1]-RC[-2]"
lrow_output = lrow_output + 1
Loop
End With
Range("B3").Sort Key1:=Range("C3"), Order1:=xlAscending, _
Key2:=Range("C4"), Order2:=xlAscending, Header:=xlYes
Exit Sub
ErrorHandler:
End Sub
Public Sub MatchingArrays()
'Dim vArray1 As Variant
'Dim vArray2 As Variant
Dim larray1_count As Long
Dim larray2_count As Long
Dim barray1_last As Boolean
Dim barray2_last As Boolean
Dim lcount_combined As Long
ReDim vCombinedList(1 To UBound(vArray1, 1) + UBound(vArray2, 1))
larray1_count = 1
larray2_count = 1
lcount_combined = 1
Do Until (barray1_last = True) And (barray2_last = True)
If vArray1(larray1_count) = vArray2(larray2_count) Then
vCombinedList(lcount_combined) = vArray1(larray1_count)
lcount_combined = lcount_combined + 1
If larray1_count < UBound(vArray1, 1) Then larray1_count = larray1_count + 1
If larray2_count < UBound(vArray2, 1) Then larray2_count = larray2_count + 1
If larray1_count = UBound(vArray1, 1) Then barray1_last = True
If larray2_count = UBound(vArray2, 1) Then barray2_last = True
Else
If vArray1(larray1_count) < vArray2(larray2_count) Then
If larray1_count = UBound(vArray1, 1) Then barray1_last = True
If larray1_count < UBound(vArray1, 1) Then larray1_count = larray1_count + 1
Else
If larray2_count = UBound(vArray2, 1) Then barray2_last = True
If larray2_count < UBound(vArray2, 1) Then larray2_count = larray2_count + 1
End If
End If
Loop
ReDim Preserve vCombinedList(1 To lcount_combined - 1)
Stop
End Sub
Public Sub RelationshipList_PopulateAdditionalColumns()
Const sPROCNAME As String = "RelationshipList_PopulateAdditionalColumns"
Dim vRelationshipList As Variant
Dim vAdditionalColumns As Variant
Dim oStartCell As Excel.Range
Dim oFinishCell As Excel.Range
Dim oRange As Excel.Range
Dim llastrow As Long
Dim lcount As Long
Dim spasterange As String
On Error GoTo ErrorHandler
Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)
vRelationshipList = Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(g_sRELATIONSHIPLIST_NAMERANGE).Value
ReDim vAdditionalColumns(1 To UBound(vRelationshipList, 1), 1 To 2)
For lcount = 1 To UBound(vRelationshipList, 1)
If (vRelationshipList(lcount, g_enRELATIONSHIPLIST.FirmId) <> "RM") Then
vAdditionalColumns(lcount, 1) = UCase(vRelationshipList(lcount, g_enRELATIONSHIPLIST.CompanyName))
vAdditionalColumns(lcount, 2) = _
modGeneral.Str_FunnyChars_Remove(UCase(vRelationshipList(lcount, g_enRELATIONSHIPLIST.MatchingName)))
End If
Next lcount
llastrow = g_lSTARTROW + Range(g_sRELATIONSHIPLIST_NAMERANGE).Rows.Count - 1
Set oStartCell = Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Cells(g_lSTARTROW, g_enRELATIONSHIP_LIST_COLUMNS.RL_CompanyName_Capitals)
Set oFinishCell = Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Cells(llastrow, g_enRELATIONSHIP_LIST_COLUMNS.RL_MatchingName_Capitals)
Set oRange = Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(oStartCell.Address & ":" & oFinishCell.Address)
oRange.Value = vAdditionalColumns
Set oStartCell = Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Cells(g_lSTARTROW, g_enRELATIONSHIP_LIST_COLUMNS.RL_FirmID)
Set oFinishCell = Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Cells(llastrow, g_enRELATIONSHIP_LIST_COLUMNS.RL_MatchingName_Capitals)
Set oRange = Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(oStartCell.Address & ":" & oFinishCell.Address)
spasterange = oRange.Address
Application.Names.Add Name:=g_sRELATIONSHIPLIST_NAMERANGE, RefersTo:=Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(spasterange)
Call RelationshipList_DefineNamedRanges(llastrow)
Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(Col_Letter(g_enRELATIONSHIP_LIST_COLUMNS.RL_MatchingName_Capitals) & g_lSTARTROW).Sort _
Key1:=Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(Col_Letter(g_enRELATIONSHIP_LIST_COLUMNS.RL_MatchingName_Capitals) & g_lSTARTROW), Header:=xlYes
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Matches two tables (with a common column) and brings in columns from one table across to the other table
Public Sub RelationshipList_Matching_PopulateTargetListColumns()
Const sPROCNAME As String = "RelationshipList_Matching_PopulateTargetListColumns"
Dim vRelationshipList As Variant
Dim vTargetList As Variant
Dim ltarget_count As Long
Dim lrelation_count As Long
Dim btarget_last As Boolean
Dim brelation_last As Boolean
On Error GoTo ErrorHandler
Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)
vRelationshipList = Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(g_sRELATIONSHIPLIST_NAMERANGE).Value
vTargetList = Sheets(g_sWSHNAME_TARGET_LIST).Range(g_sTARGETLIST_NAMERANGE).Value
ltarget_count = 1
lrelation_count = 1
Do Until (btarget_last = True) And (brelation_last = True)
If (vTargetList(ltarget_count, g_enTARGETLIST.FirmName_Capitals) = _
vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.MatchingName_Capitals)) Then
If (Len(vTargetList(ltarget_count, g_enTARGETLIST.FUM)) > 0) Then
vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.FUM) = vTargetList(ltarget_count, g_enTARGETLIST.FUM)
Else
vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.FUM) = 0
End If
vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.Classification) = vTargetList(ltarget_count, g_enTARGETLIST.FirmType)
vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.Region) = vTargetList(ltarget_count, g_enTARGETLIST.Region)
If (ltarget_count = UBound(vTargetList, 1)) Then btarget_last = True
If (lrelation_count = UBound(vRelationshipList, 1)) Then
brelation_last = True
btarget_last = True
End If
If (lrelation_count < UBound(vRelationshipList, 1)) Then lrelation_count = lrelation_count + 1
Else
If (vTargetList(ltarget_count, g_enTARGETLIST.FirmName_Capitals) < _
vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.MatchingName_Capitals)) Then
If (ltarget_count = UBound(vTargetList, 1)) Then
btarget_last = True
brelation_last = True
End If
If (ltarget_count < UBound(vTargetList, 1)) Then ltarget_count = ltarget_count + 1
Else
If (lrelation_count = UBound(vRelationshipList, 1)) Then
brelation_last = True
btarget_last = True
End If
If (lrelation_count < UBound(vRelationshipList, 1)) Then lrelation_count = lrelation_count + 1
End If
End If
Loop
Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(g_sRELATIONSHIPLIST_NAMERANGE).Value = vRelationshipList
Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(Col_Letter(g_enRELATIONSHIP_LIST_COLUMNS.RL_CompanyName_Capitals) & g_lSTARTROW).Sort _
Key1:=Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(Col_Letter(g_enRELATIONSHIP_LIST_COLUMNS.RL_CompanyName_Capitals) & g_lSTARTROW), Header:=xlYes
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Public Function RelationshipList_Lookup_TargetNameLinking(ByVal sLookup As String) As String
Dim sfindmatch As String
Dim lmatchrow As Long
On Error GoTo ErrorHandler
sfindmatch = Application.WorksheetFunction.VLookup(sLookup, Range(g_sRELATIONSHIPLIST_NAMERANGE_LOOKUPLINKING), 2, False)
lmatchrow = Application.WorksheetFunction.Match(sLookup, Range(g_sRELATIONSHIPLIST_NAMERANGE_MATCHFIRMNAME), 0) + 4
If Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(Col_Letter(g_enRELATIONSHIP_LIST_COLUMNS.RL_FirmID) & lmatchrow).Value = "RM" Then
sfindmatch = ""
End If
RelationshipList_Lookup_TargetNameLinking = sfindmatch
Exit Function
ErrorHandler:
RelationshipList_Lookup_TargetNameLinking = ""
End Function
Public Function CompaniesMeet_Lookup_CompanyNameExists(ByVal sLookup As String) As Boolean
Dim sfindmatch As String
Dim llastrow As Long
On Error GoTo ErrorHandler
sfindmatch = Application.WorksheetFunction.VLookup(sLookup, Range(g_sCOMPANIESMEET_NAMERANGE_LOOKUP_RELATIONSHIP), 1, False)
CompaniesMeet_Lookup_CompanyNameExists = True
Exit Function
ErrorHandler:
CompaniesMeet_Lookup_CompanyNameExists = False
End Function
Public Sub CompaniesMeet_Matching_PopulateRelationshipListColumns()
Const sPROCNAME As String = "CompaniesMeet_Matching_PopulateRelationshipListColumns"
Dim vRelationshipList As Variant
Dim vCompaniesMeetList As Variant
Dim lrelation_count As Long
Dim lcompanies_count As Long
Dim lrowcount As Long
Dim brelation_last As Boolean
Dim bcompanies_last As Boolean
On Error GoTo ErrorHandler
Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)
Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(g_sRELATIONSHIPLIST_NAMERANGE).Sort _
Key1:=Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(Col_Letter(g_enRELATIONSHIP_LIST_COLUMNS.RL_CompanyName_Capitals) & g_lSTARTROW), _
Order1:=XlSortOrder.xlAscending, _
Header:=xlYes
vRelationshipList = RelationshipList_FilteringToArray()
If (VBA.IsNull(vRelationshipList) = True) Then
Exit Sub
End If
Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(Col_Letter(g_enRELATIONSHIP_LIST_COLUMNS.RL_MatchingName_Capitals) & g_lSTARTROW).Sort _
Key1:=Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(Col_Letter(g_enRELATIONSHIP_LIST_COLUMNS.RL_MatchingName_Capitals) & g_lSTARTROW), Header:=xlYes
vCompaniesMeetList = Sheets(g_sWSHNAME_SERVICED).Range(g_sCOMPANIESMEET_NAMERANGE).Value
For lrowcount = 1 To UBound(vCompaniesMeetList, 1)
vCompaniesMeetList(lrowcount, 2) = _
modGeneral.Str_FunnyChars_Substitute(vCompaniesMeetList(lrowcount, 2))
Next lrowcount
vCompaniesMeetList = Array_Transpose(vCompaniesMeetList)
Call Array_SortQuickMulti1ColRowVariant("Companies Meet", vCompaniesMeetList, g_enCOMPANIESMEET.CompanyName_Capitals)
vCompaniesMeetList = Array_Transpose(vCompaniesMeetList)
lrelation_count = 1
lcompanies_count = 1
Do Until (brelation_last = True) And (bcompanies_last = True)
If (vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.CompanyName_Capitals) = _
vCompaniesMeetList(lcompanies_count, g_enCOMPANIESMEET.CompanyName_Capitals)) Then
vCompaniesMeetList(lcompanies_count, g_enCOMPANIESMEET.Classification) = _
vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.Classification)
vCompaniesMeetList(lcompanies_count, g_enCOMPANIESMEET.MatchingName_Capitals) = _
vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.MatchingName_Capitals)
If (lrelation_count = UBound(vRelationshipList, 1)) Then brelation_last = True
If (lcompanies_count = UBound(vCompaniesMeetList, 1)) Then
bcompanies_last = True
brelation_last = True
End If
If (lcompanies_count < UBound(vCompaniesMeetList, 1)) Then lcompanies_count = lcompanies_count + 1
Else
If (vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.CompanyName_Capitals) < _
vCompaniesMeetList(lcompanies_count, g_enCOMPANIESMEET.CompanyName_Capitals)) Then
If (lrelation_count < UBound(vRelationshipList, 1)) Then lrelation_count = lrelation_count + 1
If (lrelation_count = UBound(vRelationshipList, 1)) Then
brelation_last = True
If (lcompanies_count < UBound(vCompaniesMeetList, 1)) Then lcompanies_count = lcompanies_count + 1
If (lcompanies_count <= UBound(vCompaniesMeetList, 1)) Then bcompanies_last = True
End If
Else
If (lcompanies_count = UBound(vCompaniesMeetList, 1)) Then
bcompanies_last = True
brelation_last = True
End If
If (lcompanies_count < UBound(vCompaniesMeetList, 1)) Then lcompanies_count = lcompanies_count + 1
End If
End If
Loop
vCompaniesMeetList = Array_Transpose(vCompaniesMeetList)
Call Array_SortQuickMulti1ColRowVariant("Companies Meet", vCompaniesMeetList, g_enCOMPANIESMEET.CompanyName_Capitals)
vCompaniesMeetList = Array_Transpose(vCompaniesMeetList)
Sheets(g_sWSHNAME_SERVICED).Range(g_sCOMPANIESMEET_NAMERANGE).Value = vCompaniesMeetList
For lrowcount = 1 To Range(g_sCOMPANIESMEET_NAMERANGE).Rows.Count
If (Range(g_sCOMPANIESMEET_NAMERANGE).Cells(lrowcount, 2).Value = g_sINSTITUTION) Then
With Sheets(g_sWSHNAME_SERVICED)
.Range(.Cells(4 + lrowcount, 3), .Cells(4 + lrowcount, 5)).Interior.Color = g_lCOLOUR_INSTITUTION_GREY
End With
End If
Next lrowcount
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
© 2026 Better Solutions Limited. All Rights Reserved. © 2026 Better Solutions Limited TopPrev