时间戳

首页 > 解决方案 > Excel/VBA 匹配 2 个条件，提取序列中的最后一个匹配项和中断序列后的第一个匹配项

excel - Excel/VBA 匹配 2 个条件，提取序列中的最后一个匹配项和中断序列后的第一个匹配项

问题描述

我开始使用 VBA 编程，对如何从非序列数据中提取我需要的内容感到困惑。我尝试使用诸如“VLookup”、“INDEX(Match(”、“MAX(If”、“MIN(If”)之类的excel函数，但只能找到第一个或最后一个匹配项，而在序列中断的地方什么也找不到。我没有不认为 Excel 函数是可能的，这就是为什么我试图弄清楚如何在 VBA 中做到这一点。也许“如果，否则，循环”但不确定。

标准：必须具有匹配的“项目描述”和“供应商”。
输出 1：找出交货间隔后的年/周。
输出 2：查找交付缺口之前的年/周。

下面是 sheet1 上原始数据的 Excel 布局示例图像和 sheet2 上的分析。

Excel问题的图像：

标签： excelvbamatchsequential

解决方案

这段代码应该做你想做的，但检查它是否不会出错。我没有检查太多，所以它可能会产生错误。在工作簿的副本中运行它。

您应该将其放入类模块中并将其称为“CItem”：

Public pItemDescription As String
Public pSupplier As String
Public pDateDelivery As Collection

https://excelmacromastery.com/vba-class-modules/

“分析”中的那个表应该是空的。

然后进入常规模块：

Option Explicit

Sub SortCheck()

    Dim aSht As Worksheet
    Dim bSht As Worksheet

    Dim tempItemDescription As String
    Dim tempSupplier As String
    Dim tempDateDelivery As String


    Dim xItemsAll As Collection
    Dim xItem As CItem
    Dim xI As Variant
    Dim flag As Boolean

    Dim xTemp As Variant
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim Row As Long

    Set xItemsAll = New Collection
    Set xItem = New CItem

    Set aSht = Worksheets("Raw Data")
    Set bSht = Worksheets("Analysis")

    Row = 2

    flag = True

    Do
        ' If the cell is empty, stop populating the collection
        If aSht.Cells(Row, 2).Value = "" Then Exit Do

        ' ---
        tempDateDelivery = aSht.Cells(Row, 1).Value
        tempItemDescription = aSht.Cells(Row, 2).Value
        tempSupplier = aSht.Cells(Row, 3).Value

        'If xItemsAll contains some records, check wheter similar records exist
        If xItemsAll.Count > 0 Then

            For Each xI In xItemsAll

                If tempItemDescription = xI.pItemDescription And tempSupplier = xI.pSupplier Then

                    Set xItem = New CItem
                    Set xItem = xI
                    xItem.pDateDelivery.Add tempDateDelivery
                    Set xItem = Nothing
                    flag = False
                    Exit For

                Else

                    flag = True

                End If

            Next xI

        End If

        ' If the first pass or no element in collection yet, create new record

        If flag = True Then

            Set xItem = New CItem

            With xItem
                .pItemDescription = tempItemDescription
                .pSupplier = tempSupplier

                Set .pDateDelivery = New Collection
                .pDateDelivery.Add tempDateDelivery
            End With

            xItemsAll.Add xItem

            Set xItem = Nothing

            flag = False

        End If

        Row = Row + 1

    Loop


    'Sort the collection - Item Description in order
    For i = 1 To xItemsAll.Count - 1
        For j = i + 1 To xItemsAll.Count
            If xItemsAll(i).pItemDescription > xItemsAll(j).pItemDescription Then

                Set xItem = New CItem
                Set xItem = xItemsAll(j)

                xItemsAll.Remove j
                If j <> xItemsAll.Count + 1 Then
                    xItemsAll.Add xItemsAll(i), , j
                Else
                    xItemsAll.Add xItemsAll(i), , , j - 1
                End If

                xItemsAll.Remove i
                If i <> xItemsAll.Count + 1 Then
                    xItemsAll.Add xItem, , i
                Else
                    xItemsAll.Add xItem, , , i - 1
                End If

                Set xItem = Nothing

            End If
        Next j
    Next i

    'Sort the collection - Suplier in order
    For i = 1 To xItemsAll.Count - 1
        For j = i + 1 To xItemsAll.Count
            If xItemsAll(i).pItemDescription = xItemsAll(j).pItemDescription Then
                If xItemsAll(i).pSupplier > xItemsAll(j).pSupplier Then

                    Set xItem = New CItem
                    Set xItem = xItemsAll(j)

                    xItemsAll.Remove j
                    If j <> xItemsAll.Count + 1 Then
                        xItemsAll.Add xItemsAll(i), , j
                    Else
                        xItemsAll.Add xItemsAll(i), , , j - 1
                    End If

                    xItemsAll.Remove i
                    If i <> xItemsAll.Count + 1 Then
                        xItemsAll.Add xItem, , i
                    Else
                        xItemsAll.Add xItem, , , i - 1
                    End If

                    Set xItem = Nothing

                End If
            End If
        Next j
    Next i

    'Sort the collection - Dates in order
    For k = 1 To xItemsAll.Count
        For i = 1 To xItemsAll(k).pDateDelivery.Count - 1
            For j = i + 1 To xItemsAll(k).pDateDelivery.Count
                If xItemsAll(k).pItemDescription = xItemsAll(k).pItemDescription Then
                    If xItemsAll(k).pSupplier = xItemsAll(k).pSupplier Then
                        If xItemsAll(k).pDateDelivery(i) > xItemsAll(k).pDateDelivery(j) Then

                            xTemp = xItemsAll(k).pDateDelivery(j)

                            xItemsAll(k).pDateDelivery.Remove j
                            If j <> xItemsAll(k).pDateDelivery.Count + 1 Then
                                xItemsAll(k).pDateDelivery.Add xItemsAll(k).pDateDelivery(i), , j
                            Else
                                xItemsAll(k).pDateDelivery.Add xItemsAll(k).pDateDelivery(i), , , j - 1
                            End If

                            xItemsAll(k).pDateDelivery.Remove i
                            If i <> xItemsAll(k).pDateDelivery.Count + 1 Then
                                xItemsAll(k).pDateDelivery.Add xTemp, , i
                            Else
                                xItemsAll(k).pDateDelivery.Add xTemp, , , i - 1
                            End If

                        End If
                    End If
                End If
            Next j
        Next i
    Next k


    Row = 2

    For i = 1 To xItemsAll.Count
        For j = 1 To xItemsAll(i).pDateDelivery.Count - 1
            If CLng(Mid(xItemsAll(i).pDateDelivery(j + 1), 5)) <> (CLng(Mid(xItemsAll(i).pDateDelivery(j), 5)) + 1) Then

                bSht.Cells(Row, 1).Value = xItemsAll(i).pDateDelivery(j + 1)

                bSht.Cells(Row, 2).Value = xItemsAll(i).pDateDelivery(j)

                bSht.Cells(Row, 3).Value = xItemsAll(i).pItemDescription

                bSht.Cells(Row, 4).Value = xItemsAll(i).pSupplier

                Row = Row + 1

            End If
        Next j
    Next i

End Sub

要使代码正常工作，它必须是 201801、201805 等，而不是 20181、20185 等。因此，如果您有不同的代码，则必须使用函数或 vba 对其进行修改。

推荐阅读