Making an Associative Table of Unique Identifiers - vba

Question

I'm trying to create an associative table on a sheet that is pulling in data from a different sheet. By associative I mean, if the data is changed in the source data sheet, it would be reflected on the new sheet. I also want to only have the new sheet's table to be contingent on having a certain unique value. In my case, I want to pull up information related to a part number. The original source data will have many rows that contain the same part number, but I only care to display one of them.
This is what I have so far:
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Dim ref() As Variant
Dim row As Integer
row = 92
Worksheets("Part Tracking Scorecard").Activate
While Cells(row, 6).Value:
If IsInArray(Cells(row, 6).Value, ref) Then
row = row + 1
ElseIf Not IsInArray(Cells(row, 6).Value, ref) Then
ReDim Preserve ref(1 To UBound(ref) + 1) As Variant
ref(UBound(ref)) = Cells(row, 6).Value
Worksheets("Unique Parts").Activate
?????
row = row + 1
To satisfy my condition to only showcase the unique part numbers, I initialized an empty array called "ref". Then, as I iterate through the source sheet, I would check if the part number was in ref with the function "IsInArray". If it was in it, it would move onto the next row, if it wasn't add the part number into the empty array and move to the next row.
The portion with the "????" is where I'm having most of my issue trying to figure out. That part is supposed to be where I make the new table with the date from the unique part number. The very simple and tedious thing I could do is make some loop to run through the columns of the rows and put in a vlookup function. I was wondering if there may be a more robust or more elegant way in doing this.

Answer 1

You've had the right reflex tyring to define an array to stock your values. Here are a few tips of how I would get around to doing it (not perfect, but it should help you out):
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Dim Source as Worksheets
Set Source = Worksheets("Part Tracking Scoreboard")
Dim ref1(), ref2() As Variant
Dim row, index, index2 As Integer
row = 92
ref1 = Source.Range(Worksheets(Source.Cells(row,1), Source.Cells(lastrow, last column))
'Start by placing your ENTIRE source sheet in ref1, if your source sheet is big, this will help you win A LOT of time during the looping phase. Notice how I start from row 92 seeing as this is where you started your loop
'lastrow and lastcolumn represent the position of the last cell in your source file
For index = row to lastrow
If Not IsInArray(ref1(row, 6).Value, ref2) Then
ref2(index) = ref1(index) 'copy the entire row from source to ref2
Next index
Dim NewFile as Worksheet
Set Newfile = Sheets("NewSheetName")
Dim ref2dimension_x, ref2dimension_y as Integer 'find dimensions of ref2 array
ref2dimension_x= UBound(ref2, 1) - LBound(ref2, 1) + 1
ref2dimension_y = UBound(ref2, 2) - LBound(ref2, 2) + 1
For index = 2 to ref2dimension_x 'go through entire new sheet and set values
For index2 = 1 to ref2dimension_y
NewFile.Cells(index, index2).Value = ref2(index - 1, index2)
Next index2
Next index
ref1() = nothing
ref2() = nothing 'free up the space occupied by these arrays
I was not sure about what you were trying to do exactly during the else loop. If you intention is to copy the entire row, this should work. If you want to copy only specific data from the source sheet, you will need to find the indexes of the corresponding columns (hardcode them if they are not going to budge, or use a loop to find them through string comparison otherwise).

Answer 2

This solution combines some macros that I use frequently (so even if you don't use them now, they might be helpful in the future). It won't work if the data in the unique table needs to be "live", but if it'd be sufficient for it to be updated whenever the workbook is opened/closed (or on demand), this is a lot less complicated than the array version.
Basically you just:
Copy the main/unduplicated table to a new sheet
Remove duplicates by part number
Remove unnecessary columns from unduplicated table (if applicable)
I'm assuming that your source data is in a formal Excel Table (ListObject). Just swap out "PartTable" for whatever your actual table is called.
Sub makeUniqueTable()
Application.ScreenUpdating = False
Dim MainWS As Worksheet
Set MainWS = ThisWorkbook.Sheets("Part Tracking Scorecard")
Dim UniqueWS As Worksheet
Set UniqueWS = ThisWorkbook.Sheets("Unique Parts")
UniqueWS.Cells.Clear
Call cloneTable(MainWS.ListObjects("PartTable"), "UniquePartTable", UniqueWS)
Dim UniquePartTable As ListObject
Set UniquePartTable = UniqueWS.ListObjects("UniquePartTable")
Call removeDuplicates(UniquePartTable, "Part Number")
'Optional: remove unnecessary columns by listing columns to be deleted...
'Call deleteColumns(UniquePartTable, Array("Unnecessary Column 1", "Unnecessary Column 2"))
'...or kept:
'Call deleteColumns(UniquePartTable, Array("Part Number", "Manufacturer", "Product Description"), True)
Application.ScreenUpdating = True
End Sub
Sub cloneTable(tbl As ListObject, newName As String, Optional newWS As Worksheet = Nothing)
'Copies a table (tbl) to a new worksheet (newWS) and gives it a name (newName)
'If there is any data in newWS, the new table will be added to the right of the used range
'If newWS is omitted, new table will be added to same worksheet as original table
Dim ws As Worksheet
Dim lastColumn As Long
Dim newRng As Range
Dim newTbl As ListObject
If newWS Is Nothing Then
Set ws = tbl.Parent
lastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set newRng = ws.Range(ws.Cells(1, lastColumn + 2), ws.Cells(1 + tbl.ListRows.Count, lastColumn + tbl.ListColumns.Count + 1))
Else
Set ws = newWS
If ws.ListObjects.Count > 0 Then
lastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set newRng = ws.Range(ws.Cells(1, lastColumn + 2), ws.Cells(1 + tbl.ListRows.Count, lastColumn + tbl.ListColumns.Count + 1))
Else
Set newRng = ws.Range(ws.Cells(1, 1), ws.Cells(1 + tbl.ListRows.Count, tbl.ListColumns.Count))
End If
End If
tbl.Range.Copy
newRng.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Set newTbl = ws.ListObjects.Add(xlSrcRange, newRng, , xlYes)
newTbl.Name = newName
End Sub
Sub removeDuplicates(tbl As ListObject, Optional colName As Variant = "")
'Removes duplicates from a table (tbl) based on column header names (colName()) provided by user
'If no column names are provided, duplicates will be removed based on all columns in table
Dim i As Long
Dim j As Long
If Not IsArray(colName) Then
If colName = "" Then
ReDim colNumArr(0 To tbl.ListColumns.Count - 1) As Variant
For i = 0 To tbl.ListColumns.Count - 1
colNumArr(i) = tbl.ListColumns(i + 1).Range.Column
Next
Else
ReDim colNumArr(0 To 0) As Variant
colNumArr(0) = tbl.ListColumns(colName).Range.Column
End If
Else
ReDim colNumArr(0 To UBound(colName) - LBound(colName)) As Variant
j = 0
For i = LBound(colName) To UBound(colName)
colNumArr(j) = tbl.ListColumns(colName(i)).Range.Column
j = j + 1
Next
End If
tbl.Range.removeDuplicates Columns:=(colNumArr), Header:=xlYes
End Sub
Sub deleteColumns(tbl As ListObject, ByVal colName As Variant, Optional invert As Boolean = False, Optional sheetCol As Boolean = True)
'Deletes column(s) from sheet based on header names (colName) from a table (tbl)
'Will result in error if provided column contains multiple tables
'colName can be a String or an array of Strings
'Inverted mode deletes all columns *except* those in colName
Dim i As Long
Dim j As Long
Dim x As Boolean
If Not IsArray(colName) Then
tempStr = colName
ReDim colName(1 To 1) As String
colName(1) = tempStr
End If
If invert = False Then
For i = LBound(colName) To UBound(colName)
If sheetCol = True Then
tbl.Parent.Columns(tbl.ListColumns(colName(i)).Range.Column).Delete
Else
tbl.ListColumns(colName(i)).Delete
End If
Next
Else
For i = tbl.ListColumns.Count To 1 Step -1
x = False
For j = LBound(colName) To UBound(colName)
If tbl.HeaderRowRange(i).Value = colName(j) Then
x = True
Exit For
End If
Next
If x = False Then
If sheetCol = True Then
tbl.Parent.Columns(tbl.ListColumns(i).Range.Column).Delete
Else
tbl.ListColumns(i).Delete
End If
End If
Next
End If
End Sub