excel - VBA如何在分组项目列表中选择每个最后出现的字符串（最后一个项目修订版）

Question

我有一些我正在尝试做的代码，但还不是全部。我每周所做的是导出包含修订字母的大量零件编号列表。这是列表的实际示例，每种情况下的最后一个字母代表该项目编号的修订：DETA5121001 A

DETA5121001 B

DETA5121001 C

DETA5131002 A

DETA5131002 B

DETA5141003 D

DETA5141003 E

我想要做的是，通过一个宏，将列表中出现的每个部件号的文本更改为红色，这些部件号代表“旧版本”。

例如，在上面的列表中，这些不会变成红色：（DETA5121001 C、DETA5131002 B 和 DETA5141003 E），因为这 3 个部件号代表列表中每个部件号系列中的最后一个版本。我想将所有旧版本变为红色，然后将其删除。我只是厌倦了手动将文本更改为红色。

我有删除所有红色文本的宏，它是这样的：

Sub DeleteRowRedTextDec2019()

'This macro will delete a row that contains all red text in the row 12.6.19
'It will ask the user to confirm (however when we say no it deletes text anyway, separate issue)


Dim lRow As Long
Dim iCntr As Long
Dim vbAnswer As VbMsgBoxResult


lRow = 20000

vbAnswer = MsgBox(lRows & " Rows with red text will be deleted.  Do you want to continue?", vbYesNo, "Delete Rows Macro")
  
  If vbAnswer = vbYes Then
    
    'Delete Rows
    Application.DisplayAlerts = False
    Application.DisplayAlerts = True
      
  End If

For iCntr = lRow To 1 Step -1
    
    If Cells(iCntr, 1).Font.ColorIndex = 3 Then '‘3 = Red
        Rows(iCntr).Delete
    End If
Next

End Sub   

标签： excelvba

Answer 1

我将发布一些代码，一旦修改以适合您的特定状态，它们应该可以帮助您入门。我使用字典对象来保存唯一零件编号列表和相应的最新版本。填充字典后，我会再次遍历该范围，突出显示异常记录。

让我知道这是否有帮助，或者您是否需要任何额外的指导。

请注意，我做了一个关键假设：每条记录都有一个修订版，而且它始终是部分记录的最后一个字母。如果没有，我们可以进行修改，但我们需要更多信息（例如，修订是否总是用空格分隔）。

Sub HighlightOldRevisions()
    Dim sht As Worksheet
    Dim lRow As Long
    Dim oDict As Object
    Dim sPart As String
    Dim sRev As String
    
    Set oDict = CreateObject("Scripting.Dictionary")
    
    Set sht = Worksheets("Parts")
    
    'Find the last row
    lRow = 6
    
    For i = 1 To lRow
        sPart = GetPartnumber(sht.Cells(i, 1).Value)
        sRev = GetRevision(sht.Cells(i, 1).Value)
        
        If oDict.exists(sPart) Then
            If oDict(sPart) < sRev Then
                oDict(sPart) = sRev
            End If
        Else
            oDict.Add sPart, sRev
        End If
    Next i
    
    'Loop through the range again, highlight old revs
    For i = 1 To lRow
        sPart = GetPartnumber(sht.Cells(i, 1).Value)
        sRev = GetRevision(sht.Cells(i, 1).Value)
        
        If oDict(sPart) > sRev Then
            sht.Cells(i, 1).Interior.Color = vbRed
        End If
    Next i
    
End Sub

Private Function GetPartnumber(sPartWithRev As String) As String
    GetPartnumber = Split(sPartWithRev, " ")(0)
End Function

Private Function GetRevision(sPartWithRev As String) As String
    GetRevision = Split(sPartWithRev, " ")(1)
End Function