一意の識別子の関連テーブルを作成する

Question

別のシートからデータを取り込んでいるシートに結合テーブルを作成しようとしています。連想すると、ソースデータシートでデータが変更された場合、そのデータは新しいシートに反映されます。私はまた、特定のユニークな価値を持つことを条件に新しいシートのテーブルを作成したいだけです。私の場合は、部品番号に関連する情報をプルアップする必要があります。元のソースデータには、同じ部品番号を含む多くの行がありますが、そのうちの1つを表示するだけです。

これは私がこれまで持っているものです。

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"でrefになっているかどうかを確認します。その中にあれば、空の配列に部品番号を追加していない場合は次の行に移動し、次の行に移動します。

"????"私は私の問題の大部分を把握しようとしているところです。その部分は、私がユニークな部品番号からの日付で新しいテーブルを作る場所であるはずです。私ができる非常に単純で退屈なことは、行の列を実行して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