Excel 将数据从指定列提取到表

我一直在讨论使用单独的源文件自动更新报表的问题，让我简要地解释一下这个问题：

我有一个源文件，如下面的第一个截图。我只需要获取标题以红色突出显示的列中的数据

下一个必要条件是，在结果表（在单独的文件中）中，导入的记录必须基于第一列（ID）是唯一的

如何编写一个适当的宏来检查ID，跳过已有的并粘贴记录？ 我打开一个源文件开始编写代码，如下所示：

Sub Updater()
 Dim SrcWbk As Workbook
 Dim DestWbk As Workbook
 Dim Ws As Worksheet
 Dim Filename As String
 
    Set DestWbk = ThisWorkbook

    Filename = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select a Report File", MultiSelect:=False)
    
Set SrcWbk = Workbooks.Open(Filename)

SrcWbk.Activate

End Sub

---

这里有一种方法。必须提供源工作表和目标工作表的工作表名称和标题行。我在这里用常量来表示

我首先使用

Application.WorkSheetFunction.Match

从源工作表中找到需要复制的字段列。然后，我循环检查源工作表中的每个ID，并检查目标工作表中是否有匹配项。如果没有找到匹配项，则记录是新的，需要复制

然后，它只是一个简单的引用，使用前面标识的列号返回到源工作表

我在最后保存并关闭目标工作簿，但您可以根据需要删除或注释该工作簿

Sub Updater()
    
    ' Define source and destination sheets and header rows
    Const srcShtName = "Sheet1"
    Const destShtName = "Sheet1"
    Const srcHdrRow = 7
    Const destHdrRow = 1
    
    'Defing header range for source worksheet
    Set srcWS = ThisWorkbook.Worksheets(srcShtName)
    Set hdrRng = srcWS.Range(srcWS.Cells(srcHdrRow, 1), srcWS.Cells(srcHdrRow, 1).End(xlToRight))
    
    ' Get all IDs from source worksheet
    srcIdCol = Application.WorksheetFunction.Match("ID", hdrRng, 0)
    Set srcIDs = srcWS.Range(srcWS.Cells(srcHdrRow + 1, srcIdCol), srcWS.Cells(srcHdrRow + 1, srcIdCol).End(xlDown))

    ' Define fields to copy to destination worksheet and find corresponding column numbers
    fieldsToCopy = Array("Branch ID", "Product", "Shipment Category", "Port of Loading", "Year", "Month", "Day")
    ReDim srcColumns(0 To UBound(fieldsToCopy))
    fieldIdx = 0
    For Each field In fieldsToCopy
        srcColumns(fieldIdx) = Application.WorksheetFunction.Match(field, hdrRng, 0)
        fieldIdx = fieldIdx + 1
    Next field
    
    ' Open destination worksheet
    filename = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select a Report File", MultiSelect:=False)
    Set destWS = Workbooks.Open(filename).Worksheets(destShtName)
    
    ' Define header range of destination worksheet
    Set destHdrRng = destWS.Range(destWS.Cells(destHdrRow, 1), destWS.Cells(destHdrRow, 1).End(xlToRight))
    destIdCol = Application.WorksheetFunction.Match("ID", destHdrRng, 0)
    
    ' Loop through each record in source worksheet
    For Each ID In srcIDs

        ' Look for an ID in the destination worksheet that matches the current rcord
        destRow = Empty
        Set destIdRng = Intersect(destWS.Columns(destIdCol), destWS.UsedRange)
        On Error Resume Next
        destRow = Application.WorksheetFunction.Match(ID.Value, destIdRng, 0)
        On Error GoTo 0
        
        ' If destRow is empty, the record was not found in the destination and we need to add it
        If destRow = Empty Then
            nextRow = destWS.UsedRange.Rows.Count + 1
            For fieldIdx = 0 To UBound(srcColumns)
                destWS.Cells(nextRow, destIdCol).Value = ID.Value
                destWS.Cells(nextRow, fieldIdx + 2).Value = srcWS.Cells(ID.Row, srcColumns(fieldIdx)).Value
            Next fieldIdx
        End If
        
    Next ID
    
    ' Save the destination workbook and close it
    Application.DisplayAlerts = False
    destWS.Parent.Save
    destWS.Parent.Close
    Application.DisplayAlerts = True

End Sub

---

第一步：有一个excel函数可以删除某个范围的重复项。我记不起VB代码了，但是你可以记录下自己的操作，然后概括VB代码。