年会排节目单：检查同一个演员不会出现在连续的三个节目之中

本文链接：https://blog.csdn.net/Sindy_Jen/article/details/113727360

本文介绍了一个使用Excel VBA解决的问题，即确保演员不会出现在连续的三个节目中。通过创建宏和特定的VBA过程，程序会检查每个节目的演员，并在F列标记出未连续出演的演员（显示TRUE），同时在I列记录重复演员的电子邮件。此外，还引用了从文本中提取电子邮件地址的函数。

摘要由CSDN通过智能技术生成

这是一个excel VBA小程序，目的是检查演员名单不会出现在连续的三个节目之中。

这是样表：

首先，将原表格保存为带宏的格式.xlsm，然后Alt+F11调出VBA界面。

然后在相应的表格（和表单）中，创建module, 创建process (sub)。

运行的结果是，如果某个节目中的演员没有出现在后一、二、三个节目中，F列就会写上TRUE，否则为False，并且会把重复出现的演员的电子邮箱写在I列。

Sub DancerNotInNextThreePerformances()
    Dim verify As Boolean
    verify = True 'verify true means dancers are NOT in the next three rows
    Dim CellRef As Range
    
    Dim i As Integer
    
    'loop
    For i = 2 To 19
        verify = True
        Set CellRef = Worksheets("verify").Range("D" & i)
        Worksheets("verify").Range("I" & i).Value = ""
        Dim DancerList1() As String
        DancerList1 = Split(CellRef.Text, vbLf)
        Dim dancerStr As Variant
        Dim dancer As String
        
        
        Dim DancerList2 As String
        DancerList2 = Worksheets("verify").Range("D" & (i + 1)).Text
        Dim DancerList3 As String
        DancerList3 = Worksheets("verify").Range("D" & (i + 2)).Text
        Dim DancerList4 As String
        DancerList4 = Worksheets("verify").Range("D" & (i + 3)).Text
            
        For Each dancerStr In DancerList1
            Dim in2, in3, in4 As Integer
            
            dancer = ExtractEmailFun(dancerStr)
            
            in2 = InStr(1, DancerList2, dancer, vbTextCompare)
            in3 = InStr(1, DancerList3, dancer, vbTextCompare)
            in4 = InStr(1, DancerList4, dancer, vbTextCompare)
            
            If in2 <> 0 Or in3 <> 0 Or in4 <> 0 Then
                verify = False
                
                If in2 <> 0 Then
                    Worksheets("verify").Range("I" & i).Value = dancer & " " & "D" & (i + 1)
                ElseIf in3 <> 0 Then
                    Worksheets("verify").Range("I" & i).Value = dancer & " " & "D" & (i + 2)
                ElseIf in4 <> 0 Then
                    Worksheets("verify").Range("I" & i).Value = dancer & " " & "D" & (i + 3)
                End If
            End If
            
            
        Next dancerStr
        
        Worksheets("verify").Range("F" & i).Value = verify
    Next i
    
    Debug.Print "finish lala"
End Sub

这是其中使用到的提取电子邮箱的函数（function），摘自 How to quickly extract email address from text string?

Function ExtractEmailFun(ByVal extractStr As String) As String
'Update by extendoffice
Dim CharList As String
On Error Resume Next
CheckStr = "[A-Za-z0-9._-]"
OutStr = ""
Index = 1
Do While True
    Index1 = VBA.InStr(Index, extractStr, "@")
    getStr = ""
    If Index1 > 0 Then
        For p = Index1 - 1 To 1 Step -1
            If Mid(extractStr, p, 1) Like CheckStr Then
                getStr = Mid(extractStr, p, 1) & getStr
            Else
                Exit For
            End If
        Next
        getStr = getStr & "@"
        For p = Index1 + 1 To Len(extractStr)
            If Mid(extractStr, p, 1) Like CheckStr Then
                getStr = getStr & Mid(extractStr, p, 1)
            Else
                Exit For
            End If
        Next
        Index = Index1 + 1
        If OutStr = "" Then
            OutStr = getStr
        Else
            OutStr = OutStr & Chr(10) & getStr
        End If
    Else
        Exit Do
    End If
Loop
ExtractEmailFun = OutStr
End Function