Question

我需要一些帮助，请将唯一记录从一个工作簿复制到主工作簿中。

每个月我都会收到一个包含数据的新工作簿，我希望能够将该新工作簿中的所有新记录复制到一个包含所有合并记录的主工作簿。有一个唯一的引用字段可用于查找以标识新记录。除此之外，我想要做的是为主工作簿上可能在新工作簿上的所有现有记录更新3列中的值。

实施例

主要工作簿

Ref Name Value 1 Value 2 Value 3 Description
123 TR   100     50      200     xxxxxxxxxxxxxxx
111 WE   90      45      400     xxxxxxxxxxxxxxx

新工作簿

Ref Name Value 1 Value 2 Value 3 Description
123 TR   300     200      200     xxxxxxxxxxxxxxx 
456 MA   100     500      700     xxxxxxxxxxxxxxx

更新主工作簿

Ref Name Value 1 Value 2 Value 3 Description
123 TR    300     200     200    xxxxxxxxxxxxxxx
111 WE    90      45      400    xxxxxxxxxxxxxxx
456 MA    100     500     700    xxxxxxxxxxxxxxx

我很感激您的帮助。感谢

Answer 1

我写了一个小模块，可以做你想要的（甚至更多）。我试图让它尽可能通用，但我必须断言一些东西并以某种方式限制它 - 否则它会很快失控（因为我认为它已经做了......）。

限制/断言如下： 1.记录被认为仅按行排列（根据您的示例）。 2.在更新或插入值期间没有列检查。该程序假定主工作簿和新工作簿包含相同的列并以完全相同的顺序放置。 3.没有重复参考值的验证检查。假定您在每个数据范围中指定为主要键的“ref”列包含唯一值（对于该数据范围）。

除了这些假设之外，我的解决方案还通过灵活的参数（可选或自动配置 - 请参阅dataRange如何确定）进行了增强，以允许多种类型的操作。

可选 colorAlertOption 标志：允许对更新或插入的条目进行着色，以便更加明显（ true 默认情况下）
可选 rangeWithHeaders 标志：有助于确定是否需要调整提供的dataRange参数（删除标题）（默认情况下为 true ）
可选 refColIndex 整数：与dataRange的相对 - 而不是整个工作表 - 指向包含唯一引用的列的列号。（默认情况下 1 ）
必需 dataRangeNew ， dataRangeMaster （范围）参数：分别为新数据集和主数据集的数据范围的灵活表示。您可以明确地提供它们（例如“$ A $ 1：$ D $ 10”），也可以只提供包含在数据范围内任何位置的单个单元格。唯一的谓词是数据范围应与同一张纸上共存的其他可能数据隔离（通过空行或列），并且至少包含1行。

您可以像这样调用 updateMasterDataRange 过程：

call updateMasterDataRange (Workbooks(2).Sheets("new").Range("a1"), Workbooks(1).Worksheets("master").Range("a1"))

请注意完全限定的数据范围，包括混合中的工作簿和工作表。如果您不添加这些标识符，VBA将尝试将不合格的Range与ActiveWorkbook或/和ActiveWorksheet相关联，并产生不可预测的结果。

这是模块的主体：

Option Explicit
Option Base 1

Public Sub updateMasterDataRange( _
    ByRef dataRangeNew As Range, ByRef dataRangeMaster As Range, _
    Optional refColIndexNew As Integer = 1, Optional refColIndexMaster As Integer = 1, _
    Optional colorAlertOption = True, Optional rangeWithHeaders = True)

    ' Sanitize the supplied data ranges based on various criteria (see procedure's documentation)
    If sanitizeDataRange(dataRangeMaster, rangeWithHeaders) = False Then GoTo rangeError
    If sanitizeDataRange(dataRangeNew, rangeWithHeaders) = False Then GoTo rangeError

    ' Declaring counters for the final report's updated and appended records respectively
    Dim updatedRecords As Integer: updatedRecords = 0
    Dim appendedRecords As Integer: appendedRecords = 0

    ' Declaring the temporary variables which hold intermediate results during the for-loop
    Dim updatableMasterRefCell As Range, currentRowIndex As Integer, updatableRowMaster As Range

    For currentRowIndex = 1 To dataRangeNew.Rows.Count

        ' search the master's unique references (refColMaster range) for the current reference
        ' from dataRangeNew (refcolNew range)
        Set updatableMasterRefCell = dataRangeMaster.Columns(refColIndexMaster).Find( _
            what:=dataRangeNew.Cells(currentRowIndex, refColIndexNew).Value, _
            lookat:=xlWhole, searchorder:=xlByRows, searchDirection:=xlNext)

        ' perform a check to see if the search has returned a valid range reference in updatableMasterRefCell
        ' if it is found empty (the reference value in refCellNew is unique to masterDataRange)
        If updatableMasterRefCell Is Nothing Then
            Call appendRecord(dataRangeNew.Rows(currentRowIndex), dataRangeMaster, colorAlertOption)
            appendedRecords = appendedRecords + 1
            'ReDim Preserve appendableRowIndices(appendedRecords)
            'appendableRowIndices(appendedRecords) = currentRowIndex
        Else
            Set updatableRowMaster = Intersect(dataRangeMaster, updatableMasterRefCell.EntireRow)
            Call updateRecord(dataRangeNew.Rows(currentRowIndex), updatableRowMaster, colorAlertOption)
            updatedRecords = updatedRecords + 1
        End If

    Next currentRowIndex

    ' output an informative dialog to the user
    Dim msg As String
    msg = _
        "sheet name: " & dataRangeMaster.Parent.Name & vbCrLf & _
        "records updated: " & updatedRecords & vbCrLf & _
        "records appended: " & appendedRecords
    MsgBox msg, vbOKOnly, "--+ Update report +--"
    Exit Sub

rangeError:
    MsgBox "Either range argument is too small to operate on!", vbExclamation, "Argument Error"
End Sub


Sub appendRecord(ByVal recordRowSource As Range, ByRef dataRangeTarget As Range, Optional ByVal colorAlertOption As Boolean = True)

    Dim appendedRowTarget As Range
    Set dataRangeTarget = dataRangeTarget.Resize(Rowsize:=dataRangeTarget.Rows.Count + 1)
    Set appendedRowTarget = dataRangeTarget.Rows(dataRangeTarget.Rows.Count)
    appendedRowTarget.Insert shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
    Set appendedRowTarget = appendedRowTarget.Offset(-1, 0)
    ' resize datarangetarget to -1 row (because cells' shifting incurred a +1 row to dataRangeTarget)
    Set dataRangeTarget = dataRangeTarget.Resize(Rowsize:=dataRangeTarget.Rows.Count - 1)
    recordRowSource.Copy appendedRowTarget

    If colorAlertOption = True Then
        ' fills the cells of the newly appended row with lightgreen color
        appendedRowTarget.Interior.color = RGB(156, 244, 164)
    End If

End Sub


Sub updateRecord(ByVal recordRowSource As Range, ByVal updatableRowTarget As Range, Optional ByVal colorAlertOption As Boolean = True)
    recordRowSource.Copy updatableRowTarget
    If colorAlertOption = True Then
        ' fills the cells of the updated row with lightblue color
        updatableRowTarget.Interior.color = RGB(164, 189, 249)
    End If
End Sub


Private Function sanitizeDataRange(ByRef target As Range, ByVal rangeWithHeaders As Boolean) As Boolean

    ' if data range comprises only 1 cell then try to expand the range to currentRegion
    ' (all neighbouring cells until the selection reaches boundaries of blank rows or columns)
    If target.Cells.Count = 1 Then
        Set target = target.CurrentRegion
    End If

    ' remove headers from data ranges if flag RangeWithHeaders is true
    If (rangeWithHeaders) Then
        If (target.Rows.Count >= 2) Then
            Set target = target.Offset(1, 0).Resize(Rowsize:=(target.Rows.Count - 1))
        Else
            sanitizeDataRange = False
        End If
    End If

    sanitizeDataRange = IIf((target.Rows.Count >= 1), True, False)

End Function

您的示例上的简单执行结果给出了预期的结果，如附图所示。甚至还有关于已完成的行动的简短报告的对话。

enter image description here

Answer 2

你没有多少开始。这个大纲会让你开始吗？

open all 3 workbooks
for masterrow = beginrow to endrow
  if match in newsheet then
    updaterow = newrow
  else
    updaterow = masterrow
  end if
next masterrow
' now pick up unmatched newrows
for newrow = beginrow to endrow
  if not match in updatesheet then
    updaterow = newrow
  end if
next newrow

编辑：CodeVortex做了整件事。我的大纲有缺陷。

open both workbooks
appendrow = endrow of mastersheet
for newrow = beginrow to endrow
  if match in mastersheet then
    update masterrow
  else
    append into appendrow
    appendrow = appendrow + 1
  end if
next newrow

将唯一记录从一个工作簿复制到另一个主工作簿

2 个答案: