Question

设置

每隔一段时间，我会收到一个来自另一个组的工作表（master）：它有大约250000行。

我的小组的工作是确定每个项目。为了方便这项工作，我有一些代码将master按主要部分（01,02等）拆分为单个工作簿：

例如，Outline_01.xlsx看起来与master完全相同，但在第20行之后没有任何内容。一旦我的论坛处理了它，就会添加数据列，使其如下所示：

问题

我需要将我的团队数据从单个部分的工作表中提取到master。 但是，当时间到了，我有一个来自其他组master2的更新工作表：

从master到master2的可能更改

删除整个条目[黄松]
修改名称[短毛猫 - ＆gt;国内短毛猫]
添加整个（可能是错误分类的）条目[elephant]

当相关流程完成后，master2应如下所示：

当前的解决方案

我当前的代码在master2中运行，搜索每个单独的部分工作表中的每个条目，并将master2中的相应单元格分配给Outline_*中的相应单元格：

Option Explicit

Sub GatherData()

    'Set up for speed
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    'Get files to be processed
    Dim DataFolder As String
    Dim DataFile As String
    DataFolder = "\\Some\Network\Location"
    DataFile = Dir(DataFolder & "\Outline_*.xlsx")

    'Define ranges to search
    Dim rngID_main As Range
    Dim rngID_sub As Range
    Dim rngID_subsub As Range
    With ThisWorkbook.Worksheets("Sheet1")
        Set rngID_main = .Range("A2", "A" & .Range("G2").End(xlDown).Row)
        Set rngID_sub = .Range("C2", "C" & .Range("G2").End(xlDown).Row)
        Set rngID_subsub = .Range("E2", "E" & .Range("G2").End(xlDown).Row)
    End With

    Dim rngToSearch As Range
    Dim MatchPos As Variant
    Dim Cell As Range

    'Find and copy data
    Do While DataFile <> ""
        Workbooks.Open Filename:=DataFolder & "\" & DataFile
        With Workbooks(DataFile).Worksheets("Sheet1")
            Set rngToSearch = .Range("A2:" & "A" & .Range("A" & .Rows.Count).End(xlUp).Row & _
                ",C2:" & "C" & .Range("C" & .Rows.Count).End(xlUp).Row & _
                ",E2:" & "E" & .Range("E" & .Rows.Count).End(xlUp).Row)
            .Rows.EntireRow.Hidden = False
        End With
        For Each Cell In rngToSearch
            If IsNumeric(Left(Cell.Value2, 2)) Then
                Select Case Cell.Rows.OutlineLevel
                    Case Is < 4
                        MatchPos = Application.Match(Cell.Value2, rngID_main, 0)
                    Case 4
                        MatchPos = Application.Match(Cell.Value2, rngID_sub, 0)
                    Case 5
                        MatchPos = Application.Match(Cell.Value2, rngID_subsub, 0)
                End Select
                If IsError(MatchPos) Then
                    Debug.Print Cell.Value2 & " not found"
                Else
                    'Increment because ranges start on row 2
                    MatchPos = MatchPos + 1
                    'Transfer data
                    Workbooks(DataFile).Worksheets("Sheet1").Range("H" & Cell.Row, "J" & Cell.Row).Value2 = _
                        ThisWorkbook.Worksheets("Sheet1").Range("H" & MatchPos, "J" & MatchPos).Value2
                End If
            End If
            DoEvents
        Next Cell
        With Workbooks(DataFile)
            .Save
            .Close
        End With
        DataFile = Dir
    Loop

    'Return to regular configuration
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic

End Sub

此代码在250000行master2上运行大约需要30分钟（Range.Find的速度要慢得多）。 master和master2之间的差异相对较小：可能添加了25项，删除了25项，更改了100项;我希望有一个利用这种程度的解决方案。我想要比较大于一行的部分，但我不知道选择这些部分的大小并处理找到导致它们不匹配的原因的有效算法。不幸的是，由于对我正在处理的数据有一些深奥的规定，使用更好的工具来完成这项工作（一个实际的数据库）是受到限制的;我另外不能依赖第三方加载项。但是，解决方案不需要严格的VBA。

如何有效地将次要更改合并到类似数据库的电子表格中？

设置

问题

当前的解决方案

0 个答案: