vb

Sub 按钮1_Click()

Call ExportData

    Dim myRegExp As Object
    Dim myRegExpNew As Object
    Dim Myrange As Range, C As Range, rg As Range
    Dim TTLabel As String

    Set myRegExp = CreateObject("vbscript.regexp")
    myRegExp.Pattern = "o?p?t?-\w+-?\w+-?"
    myRegExp.IgnoreCase = True
    myRegExp.Global = True
   

   
    Set Myrange = ActiveSheet.Range("B3:B70")
    Set rg = Worksheets("sheet2").Range("E5:F5", "E17:F17")
   
    TTLabel = Left(Worksheets("sheet2").Range("E5").Value, 3)
   
   
   
    For Each C In Myrange
   
        Set myMatches = myRegExp.Execute(C.Value)
        If myMatches.Count >= 1 Then
            For Each myMatch In myMatches
           
                'Debug.Print myMatch
                Set notExactLab = rg.Find(What:=myMatch)
                If notExactLab Is Nothing Then
                    Set notExactLab = myMatch
                    C.Offset(0, 1).Value = C.Offset(0, 1).Value + vbCrLf + "(" + notExactLab + ")"
                Else
                    res1 = Application.VLookup(notExactLab, rg, 2, 0)
                    C.Offset(0, 1).Value = C.Offset(0, 1).Value + vbCrLf + "(" + notExactLab + ")" + IIf(IsError(res1), "", res1)
                   
                End If
               
               
           Next
        End If
        C.Offset(0, 1).Value = Replace(C.Offset(0, 1).Value, "(T", "(" + TTLabel)
        C.Offset(0, 1).Value = Replace(C.Offset(0, 1).Value, "(opt", "(" + TTLabel + "-opt")
    Next
    Application.ScreenUpdating = True
End Sub

Sub ExportData()

Application.ScreenUpdating = False
Sheets(1).UsedRange.ClearContents
With CreateObject("Adodb.Connection")
.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;';data source=" + ThisWorkbook.Path + "\test.xls"
[B3].CopyFromRecordset .Execute("select * from [Sheet1$] ")
.Close
End With



End Sub

                Set notExactLab = rg.Find(What:=myMatch)
               
                If notExactLab Is Nothing Then
                    Set notExactLab = myMatch
                    '显示无法匹配的标签
                    C.Offset(0, 1).Value = C.Offset(0, 1).Value + vbCrLf + "(" + notExactLab + ")"
                Else
                    firstAddress = notExactLab.Address

                    Set nextMatchCell = rg.FindNext(notExactLab)
                    While Not nextMatchCell Is Nothing And firstAddress <> nextMatchCell.Address
                        '显示重复项
                        ActiveSheet.Range("D1").Value = ActiveSheet.Range("D1").Value + vbCrLf + "(" + nextMatchCell + ")" + nextMatchCell.Offset(0, 1).Value
                        '注意一定要这么写，不然就死循环
                        Set nextMatchCell = rg.FindNext(nextMatchCell)
                      
                    Wend
                   
                   
                    res1 = Application.VLookup(notExactLab, rg, 2, 0)
                    C.Offset(0, 1).Value = C.Offset(0, 1).Value + vbCrLf + "(" + notExactLab + ")" + IIf(IsError(res1), "", res1)
                   
                End If