合并两个重叠的日期范围表答案

【问题标题】：Combine two overlapping tables of date ranges合并两个重叠的日期范围表
【发布时间】：2017-12-07 08:07:08
【问题描述】：

我正在尝试在 Excel 中合并两个带有日期范围的表格。

我有具有特定季节性定价的属性，并且我有具有其他季节性利润的套餐，我需要将两者的日期括号结合起来。

我可以算出 VBA 中的所有利润/定价信息。它包含在这里是因为在某些情况下数据看起来相同，即使它不是。但我什至连开始合并日期都没有运气。

这是主表；通过连接两个表/范围创建的任何日期都应包含在这些日期中：

我需要将此类区域数据与特定属性数据合并：

当我将它们组合起来时，它需要看起来像这样：

我可以轻松地将数据转储到 SQL 中，但我需要公司中的任何人都可以从 Excel 电子表格中复制的东西。

我尝试了各种公式方案 - 做这个，然后那个，然后这个其他的事情。我尝试过使用电源查询进行交叉连接，然后尝试消除我不想要的日期。这些都不起作用。

我从 gitgo 知道它想在 VBA 中完成，而我尝试的所有其他方法都是一种拖延战术。问题是，我似乎无法完全理解所需的逻辑。对于这个逻辑，我有不止一个用例。

所有属性日期都必须存在于主表中（在一个范围内）。属性的日期可能根本不存在于主要范围内。

【问题讨论】：

已经尝试过万能的 vlookup 了吗？
我需要比第一组的计数和第二组的计数更多的记录。括号创建取决于集合相交的位置。这就是为什么最后一个（所需的）集合中的记录比前两个集合中的记录多的原因。在这种情况下，Vlookup 没有帮助。
需要明确的是，第一组中的记录数（区域/边距）将在 70 到 100 之间。物业记录的数量（价格按日期变化）可能会达到 1000或更多。
5 分钟不足以输入一个连贯的答案，所以我把所有的编辑都打乱了。无论如何，如果我在第一组中为第二组中的每条记录提供一条记录，或者如果我们实际上没有创建多个新的日期括号，则 Vlookup 很有用。因此，具有两个价格括号、重叠 2 个区域/边距括号的属性可能会产生七行数据。看完成的例子，和原始数据对比一下，会更有意义。

标签： excel vba excel-2010

【解决方案1】：

我确信有更有效的方法，但这里是我将如何使用命名的数据表和输出的范围来做到这一点。您应该能够对其进行修改以适应。逻辑比我想象的要复杂一些。代码下方是我的测试输出的屏幕截图，与您的表格匹配。

Option Explicit
Sub TableMerge()
    Dim i As Integer
    Dim j As Integer
    Dim insert_row As Integer
    Dim prev_FINISH As Date
    Dim Table_1 As ListObject
    Dim Table_2 As ListObject

    insert_row = 2
    prev_FINISH = CDate("01/01/1900")

    Set Table_1 = ActiveSheet.ListObjects("Table1")
    Set Table_2 = ActiveSheet.ListObjects("Table2")

    For i = 1 To Table_2.ListRows.Count
        For j = 1 To Table_1.ListRows.Count

        ' assumes the headers are in place, using range L:R for Table3
            If (Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("REG").Index) = Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("REG").Index)) And (Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Finish").Index) > Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Start").Index)) And (Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("sTART").Index) < Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Finish").Index)) Then
                If (prev_FINISH = CDate("01/01/1900") And (Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Start").Index) <= Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Finish").Index))) Or (prev_FINISH >= Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Start").Index)) Or (Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Finish").Index) >= Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Start").Index)) Then

                'If (prev_FINISH = CDate("01/01/1900") And (Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Start").Index) <= Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Finish").Index)) 'Or (Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Finish").Index) >= Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Finish").Index))) Then
                ' add new entry
                    ActiveSheet.Range("L" & insert_row).Value = Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("REG").Index)
                    ActiveSheet.Range("M" & insert_row).Value = Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Name").Index)
                    ActiveSheet.Range("N" & insert_row).Value = maxoftwo(maxoftwo(Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Start").Index), Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Start").Index)), prev_FINISH)
                    ActiveSheet.Range("O" & insert_row).Value = minoftwo(Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Finish").Index), Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Finish").Index))
                    ActiveSheet.Range("P" & insert_row).Value = Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("MARG").Index)
                    ActiveSheet.Range("Q" & insert_row).Value = Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("COST").Index)
                    ActiveSheet.Range("R" & insert_row).Formula = "=Q:Q/(1-P:P)"
                    If ActiveSheet.Range("O" & insert_row).Value <> Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Finish").Index) Then
                        prev_FINISH = ActiveSheet.Range("O" & insert_row).Value
                    Else
                        prev_FINISH = CDate("01/01/1900")
                        j = 1
                        insert_row = insert_row + 1
                        GoTo Next_i
                    End If
                    insert_row = insert_row + 1
                End If
            End If
        Next j
        prev_FINISH = CDate("01/01/1900")
    Next_i:
    Next i
End Sub

Function maxoftwo(date1 As Date, date2 As Date) As Date
    maxoftwo = date1
    If date2 > date1 Then maxoftwo = date2
End Function

Function minoftwo(date1 As Date, date2 As Date) As Date
    minoftwo = date1
    If date2 < date1 Then minoftwo = date2
End Function

【讨论】：

谢谢，我会检查一下。（今天推出了一个新网站，有点疯狂，所以可能需要一点时间。）我正在创建一些日期数组并相应地标记它们，这看起来要简单得多。如果我有任何问题，我会告诉你。
我找到了一个对我/一般数据更快/更好的解决方案，但这确实适用于给定的数据，所以我赞成。
我会在接下来的几天里做这个，虽然它更多的是描述而不是实际代码。

【解决方案2】：

2017 年 7 月 6 日的原始答案可能适用于上述数据集，但如果 Table2 中的值的结束日期等于关联 Table1 记录的开始日期（在这种情况下，一天将从决赛桌中省略）。我相信我已经通过在第一个 IF 语句中添加“=”来解决这个问题。还注意到粘贴值时有两个“maxoftwo”堆叠在一起，不知道为什么 - 代码似乎只用 1 就可以正常工作。

很长一段时间以来，我一直在寻求帮助来实现这一目标，而这个主题是我迄今为止找到的唯一答案。如果其他人注意到错误或有更好的方法来增强它，请告诉。谢谢

    Option Explicit
Sub TableMerge()
    Dim i As Integer
    Dim j As Integer
    Dim insert_row As Integer
    Dim prev_FINISH As Date
    Dim Table_1 As ListObject
    Dim Table_2 As ListObject

    insert_row = 2
    prev_FINISH = CDate("01/01/1900")

    Set Table_1 = ActiveSheet.ListObjects("Table1")
    Set Table_2 = ActiveSheet.ListObjects("Table2")

    For i = 1 To Table_2.ListRows.Count
        For j = 1 To Table_1.ListRows.Count

        ' assumes the headers are in place, using range L:R for Table3
            If (Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("REG").Index) = Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("REG").Index)) And (Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Finish").Index) >= Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Start").Index)) And (Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("sTART").Index) <= Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Finish").Index)) Then
                If (prev_FINISH = CDate("01/01/1900") And (Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Start").Index) <= Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Finish").Index))) Or (prev_FINISH >= Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Start").Index)) Or (Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Finish").Index) >= Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Start").Index)) Then

                'If (prev_FINISH = CDate("01/01/1900") And (Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Start").Index) <= Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Finish").Index)) 'Or (Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Finish").Index) >= Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Finish").Index))) Then
                ' add new entry
                    ActiveSheet.Range("L" & insert_row).Value = Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("REG").Index)
                    ActiveSheet.Range("M" & insert_row).Value = Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Name").Index)
                    ActiveSheet.Range("N" & insert_row).Value = maxoftwo(Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Start").Index), Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Start").Index))
                    ActiveSheet.Range("O" & insert_row).Value = minoftwo(Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("Finish").Index), Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Finish").Index))
                    ActiveSheet.Range("P" & insert_row).Value = Table_1.DataBodyRange.Cells(j, Table_1.ListColumns("MARG").Index)
                    ActiveSheet.Range("Q" & insert_row).Value = Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("COST").Index)
                    ActiveSheet.Range("R" & insert_row).Formula = "=Q:Q/(1-P:P)"
                    If ActiveSheet.Range("O" & insert_row).Value <> Table_2.DataBodyRange.Cells(i, Table_2.ListColumns("Finish").Index) Then
                        prev_FINISH = ActiveSheet.Range("O" & insert_row).Value
                    Else
                        prev_FINISH = CDate("01/01/1900")
                        j = 1
                        insert_row = insert_row + 1
                        GoTo Next_i
                    End If
                    insert_row = insert_row + 1
                End If
            End If
        Next j
        prev_FINISH = CDate("01/01/1900")
    Next_i:
    Next i
End Sub

Function maxoftwo(date1 As Date, date2 As Date) As Date
    maxoftwo = date1
    If date2 > date1 Then maxoftwo = date2
End Function

Function minoftwo(date1 As Date, date2 As Date) As Date
    minoftwo = date1
    If date2 < date1 Then minoftwo = date2
End Function

【讨论】：