Excel/VBA 匹配 2 个条件，提取序列中的最后一个匹配项和中断序列后的第一个匹配项
Excel/VBA to match 2 criteria, extracting last match in sequence and first match after broken sequence
我开始使用 VBA 编程，并且对如何从非顺序数据中提取我需要的内容感到困惑。
我尝试使用 excel 函数，例如 "VLookup"、"INDEX(Match("、"MAX(If"、"MIN(If"，但只能找到第一个或最后一个匹配项，而在序列所在的位置周围找不到任何东西休息。我不认为使用 Excel 函数是可能的，这就是为什么我试图弄清楚如何在 VBA 中做到这一点。也许 "If, Else, Loop" 但不确定。
条件：必须具有匹配的 "Item desc" 和 "Supplier"。
输出 1：在交付缺口之后找到 Year/Week。
输出 2：在交付缺口之前找到 Year/Week。
下面是 Excel 工作表 1 上的原始数据布局和工作表 2 上的分析的示例图像。
Image of Excel issue:
这段代码应该可以满足您的要求，但请检查它是否没有出错。
我没有检查太多，所以它可能会产生错误。
运行 它在工作簿的副本中。
你应该将它放入 class 模块并命名为 'CItem':
Public pItemDescription As String
Public pSupplier As String
Public pDateDelivery As Collection
https://excelmacromastery.com/vba-class-modules/
'Analysis' 中的 table 应该是空的。
然后进入常规模块：
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 修改它。
我开始使用 VBA 编程，并且对如何从非顺序数据中提取我需要的内容感到困惑。 我尝试使用 excel 函数，例如 "VLookup"、"INDEX(Match("、"MAX(If"、"MIN(If"，但只能找到第一个或最后一个匹配项，而在序列所在的位置周围找不到任何东西休息。我不认为使用 Excel 函数是可能的，这就是为什么我试图弄清楚如何在 VBA 中做到这一点。也许 "If, Else, Loop" 但不确定。
条件：必须具有匹配的 "Item desc" 和 "Supplier"。
输出 1：在交付缺口之后找到 Year/Week。
输出 2：在交付缺口之前找到 Year/Week。
下面是 Excel 工作表 1 上的原始数据布局和工作表 2 上的分析的示例图像。
Image of Excel issue:
这段代码应该可以满足您的要求，但请检查它是否没有出错。 我没有检查太多，所以它可能会产生错误。 运行 它在工作簿的副本中。
你应该将它放入 class 模块并命名为 'CItem':
Public pItemDescription As String
Public pSupplier As String
Public pDateDelivery As Collection
https://excelmacromastery.com/vba-class-modules/
'Analysis' 中的 table 应该是空的。
然后进入常规模块：
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 修改它。