制作唯一标识符的关联表
我正在试图在一张表格上创build一个关联表格，这个表格从另一张表格中提取数据。 通过关联我的意思是，如果源数据表中的数据发生更改，则会反映在新表中。 我也希望只有新的表格才具有一定的独特价值。 在我的情况下，我想提取有关零件编号的信息。 原始的源数据将有许多行包含相同的部件号，但我只关心显示其中之一。
这是我迄今为止：
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 为了满足我的条件，只展示了独特的零件号码，我初始化了一个名为“ref”的空数组。 然后，当我遍历源表单时，我会检查部分号是否在函数“IsInArray”中。 如果它在里面，它将移动到下一行，如果不是将零件号码添加到空数组中并移动到下一行。
“????”部分 是我最需要解决的问题。 这部分应该是我用独特的零件号码的date与新的表格。 我可以做的非常简单和乏味的事情是做一些循环来遍历行的列并放入一个vlookup函数。 我想知道这样做是否可能有一个更强大或更优雅的方式。
你有正确的反应tyring定义一个数组来存储你的值。 这里有一些关于如何去做的提示（不完美，但应该会帮助你）：
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
我不确定在else循环中你想要做什么。 如果你的意图是复制整个行，这应该工作。 如果只想复制源表中的特定数据，则需要查找相应列的索引（如果它们不打算使用它们进行硬编码，或者使用循环通过string比较来查找它们）。
这个解决scheme结合了我经常使用的一些macros（所以即使你现在不使用它们，它们在将来也许会有所帮助）。 如果唯一表中的数据需要“实时”，那么这将不起作用，但是如果只要工作簿打开/closures（或根据需要）就足以使其更新，那么这将不复杂比arrays版本。
基本上你只是：
- 将主/不重复的表复制到新工作表
- 通过零件号删除重复项
- 从不重复的表中删除不必要的列（如果适用）
我假设你的源数据是在一个正式的Excel表（ListObject）。 只要换掉“PartTable”，无论你的实际表被调用。
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