製作唯一標識符的關聯表

Question

我試圖在從不同工作表拉取數據的工作表上創建關聯表。通過關聯我的意思是，如果源數據表中的數據發生更改，它將反映在新表中。我也只想讓新表的表格具有一定的獨特價值。就我而言，我想提取與零件編號有關的信息。原始源數據將包含許多包含相同部件號的行，但我只關心顯示其中的一個。

這是我到目前爲止有：

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 

爲了滿足我的條件，只展示了獨特的零件號，我初始化的所謂的「裁判」空數組。然後，當我迭代源表單時，我會檢查零件編號是否在參考函數「IsInArray」中。如果它在裏面，它會移動到下一行，如果它不是將零件號碼添加到空數組並移動到下一行。

「????」是我最需要解決的問題。該部分應該是我用獨特的部件號製作新表的日期。我可以做的非常簡單而乏味的事情是創建一些循環來遍歷行的列並放入一個vlookup函數。我想知道這樣做是否會有更強大或更優雅的方式。

Answer 1

你已經有了正確的反射方法來定義一個數組來存儲你的值。下面是我將如何得到解決，以做一些提示（不完美，但它應該幫助你）：

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 

我不知道你試圖在其他循環中做的正是。如果你的意圖是複製整行，這應該工作。如果您只想複製源表中的特定數據，則需要查找相應列的索引（如果它們不預算，則對其進行硬編碼，否則使用循環通過字符串比較來查找它們）。

Answer 2

這個解決方案結合了我經常使用的一些宏（所以即使你現在不使用它們，它們在未來可能會有所幫助）。如果獨特表格中的數據需要「實時」，它將無法工作，但是如果只要工作簿打開/關閉（或根據需要）就足以使其更新，則這種方法要複雜得多比陣列版本。

基本上你只是：

• 複製主/不重複的表，以一個新的工作表
• 部件編號刪除重複
• 刪除不必要的列從不重複的表（如果適用）

我假設你的源數據是在一個正式的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