Excel / VBA для соответствия 2 критериям, извлекая последнее совпадение в последовательности и первое совпадение после прерывистой последовательности

Question

Я начинаю использовать программирование на VBA и не могу понять, как извлечь то, что мне нужно, из непоследовательных данных.Я пытался использовать функции Excel, такие как «VLookup», «INDEX (Match (», «MAX (If», «MIN (If»), но я могу найти только первое или последнее совпадение и ничего там, где разрывается последовательность.Я не думаю, что это возможно с функциями Excel, поэтому я пытаюсь выяснить, как сделать это в VBA. Может быть, «Если, иначе, цикл», но не уверен.

Критерии: должно иметь соответствие »Item desc"и" Поставщик ".
Выход 1: Найти год / неделю после перерыва в доставке.
Выход 2: Найти год / неделю до перерыва в доставке.

Ниже приведен пример изображения макета Excel снеобработанные данные на листе 1 и анализ на листе 2.

Изображение выпуска Excel:

Answer 1

Этот код должен делать то, что вы хотите, но проверьте, не делает ли он ошибки.Я не слишком проверял это, так что это может привести к ошибкам.Запустите его в копии рабочей книги.

Вы должны поместить это в модуль класса и назвать его '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.