正規表現による検索

正規表現による検索２しゅるい

    Sub 文字列検索()
    
      Dim wb As Workbook
      Dim ws As Worksheet
    
      Set wb = ThisWorkbook
      Set ws = wb.Worksheets("sheet1")
    
    '  汎用変数
      Dim i As Long, k As Long
      Dim rng As Range
    
    '  サーチ用変数(正規表現を使用)
    
      Dim rg As New RegExp
      Const rgPtn1 As String = "信号"
      Const rgPtn2 As String = "IDコード"
      Const rgPtn3 As String = "削除予定"
      Const rgPtn4 As String = "脅威分析"
      
      Dim topRng_sig As Range
      Dim topRng_id As Range
      Dim topRng_tblOnly As Range
      Dim topRng_q As Range
      
      Dim clm_sig As Long
      Dim clm_id As Long
      Dim clm_tbl As Long
      Dim clm_q As Long
      Dim topRow_sig As Long
      Dim btmRow_sig As Long
      
      Dim ary_for_cmpr() As Variant
      
      Dim sig As String
      Dim sig_k As String
      Dim sig_rp As String
      Dim id_k As String
      
      Dim fst_flg As Boolean
      
    '  各対象列、行を検索
      Set topRng_sig = CellSearchByKeyword(rgPtn1, ws)  'wsからrgPtn1を探してrangeを返す
      Do
        Set topRng_sig = topRng_sig.Offset(1)
      Loop While topRng_sig.Value = ""
      topRow_sig = topRng_sig.Row
      clm_sig = topRng_sig.Column
      btmRow_sig = ws.Cells(ws.Rows.Count, clm_sig).End(xlUp).Row
    
      Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(500, 200))
      Set topRng_id = CellSearchByKeywordVerRange(rgPtn2, rng)  'rngからrgPtn2を探してrangeを返す
      clm_id = topRng_id.Column
      
      Set topRng_tblOnly = CellSearchByKeyword(rgPtn3, ws)  'wsからrgPtn3を探してrangeを返す
      clm_tbl = topRng_tblOnly.Column
      
      Set topRng_q = CellSearchByKeyword(rgPtn4, ws)  'wsからrgPtn4を探してrangeを返す
      clm_q = topRng_q.Column
      
      ReDim ary_for_cmpr(btmRow_sig - topRow_sig, 5)
      For i = 0 To UBound(ary_for_cmpr, 1)
        ary_for_cmpr(i, 0) = ws.Cells(topRow_sig + i, clm_sig)  '信号名格納
        ary_for_cmpr(i, 1) = ws.Cells(topRow_sig + i, clm_id)  'ID格納
        ary_for_cmpr(i, 2) = ws.Cells(topRow_sig + i, clm_tbl)  '削除予定符号格納
        ary_for_cmpr(i, 3) = ws.Cells(topRow_sig + i, clm_q)  '脅威分析格納
    '    ary_for_cmpr(,4)　消去行フラグ
    '    ary_for_cmpr(,5)　CANtableに記載の信号名
      Next i
      
      
      rg.Global = True
      rg.IgnoreCase = False
      
      For i = 0 To UBound(ary_for_cmpr, 1)
        sig = ary_for_cmpr(i, 0)
    
        For k = 0 To UBound(ary_for_cmpr, 1)
      
          sig_k = ary_for_cmpr(k, 0)
          id_k = ary_for_cmpr(k, 1)
          rg.Pattern = sig & ".+"
          If rg.test(sig_k) Then
            If Right("0000000" & ary_for_cmpr(i, 1), 8) = Right("0000000" & id_k, 8) Then
            
              rg.Pattern = "^0+"
              id_k = rg.Replace(id_k, "")
              If Len(sig_k) - InStr(sig_k, id_k) + 1 = Len(id_k) Then
                sig_rp = ""
                If ary_for_cmpr(i, 2) <> "" Then
                  sig_rp = sig
                ElseIf ary_for_cmpr(k, 2) <> "" Then
                  sig_rp = sig_k
                End If
                
                If ary_for_cmpr(k, 3) = "" Then
                  ary_for_cmpr(k, 4) = True
                  ary_for_cmpr(i, 5) = sig_rp
                ElseIf ary_for_cmpr(i, 3) = "" Then
                  ary_for_cmpr(i, 4) = True
                  ary_for_cmpr(k, 5) = sig_rp
                End If
              End If
              
            End If
          End If
          
        Next k
      Next i
      
      fst_flg = False
    '  For i = 0 To UBound(ary_for_cmpr, 1)
    '    If ary_for_cmpr(i, 5) <> "" Then
    '      ws.Cells(i + topRow_sig, clm_sig) = ary_for_cmpr(i, 5)
    '    End If
    '  Next i
      For i = 0 To UBound(ary_for_cmpr, 1)
        If ary_for_cmpr(i, 4) = True And fst_flg = False Then
          Set rng = ws.Rows(topRow_sig + i)
          fst_flg = True
        ElseIf ary_for_cmpr(i, 4) = True Then
          Set rng = Application.Union(rng, ws.Rows(topRow_sig + i))
        End If
      Next i
      
    '  Selection.Delete
      rng.Select
      
      
    End Sub
    
    
    '検索したいワード、検索の対象範囲となるworksheetを引数にして、検索ワードが存在するrangeを返す
    Function CellSearchByKeyword(ByVal srchWrd As String, ByVal ws As Object) As Range
    
    '  引数として受け取るwsをそのまま使用して配列変数にrangeを入れようとするとエラーとなるため定義し直す
      Dim ws_cnv As Worksheet
      Set ws_cnv = ws.Parent.Worksheets(ws.Name)
      
      Dim i As Long
      Dim lp_ary As Variant
      Dim ary_srchRng() As Variant
      Const row_srchRng As Long = 500
      Const clm_srchRng As Long = 200
      Dim multiFindFlag As Boolean
      
      Dim rg As New RegExp
      rg.Global = True
      rg.IgnoreCase = False
      rg.Pattern = srchWrd
      
      ary_srchRng = ws_cnv.Range(ws_cnv.Cells(1, 1), ws_cnv.Cells(row_srchRng, clm_srchRng))
      i = 0
      multiFindFlag = False
      For Each lp_ary In ary_srchRng
        i = i + 1
        If rg.test(lp_ary) = True Then
          If multiFindFlag = True Then
            MsgBox srchWrd & " で検索した結果、複数のセルがヒットしました"
            End
          End If
          Set CellSearchByKeyword = ws_cnv.Cells(i Mod row_srchRng, Int(i / row_srchRng) + 1)
          multiFindFlag = True
        End If
      Next lp_ary
      If CellSearchByKeyword Is Nothing Then
        MsgBox srchWrd & " で検索しましたがヒットしませんでした"
        End
      End If
    
    End Function
    
    
    '検索したいワード、検索の対象範囲となるrangeを引数にして、検索ワードが存在するrangeを返す
    Function CellSearchByKeywordVerRange(ByVal srchWrd As String, ByVal srchRng As Object) As Range
      
      Dim i As Long
      Dim lp_ary As Variant
      Dim ary_srchRng() As Variant
      Dim rows_srchRng As Long
      Dim topRow As Long
      Dim leftClm As Long
      Dim multiFindFlag As Boolean
      
      Dim rg As New RegExp
      rg.Global = True
      rg.IgnoreCase = False
      rg.Pattern = srchWrd
      
      rows_srchRng = srchRng.Rows.Count
      topRow = srchRng.Row
      leftClm = srchRng.Column
      
      ary_srchRng = srchRng
      i = 0
      multiFindFlag = False
      For Each lp_ary In ary_srchRng
        i = i + 1
        If rg.test(lp_ary) = True Then
          If multiFindFlag = True Then
            MsgBox srchWrd & " で検索した結果、複数のセルがヒットしました"
            End
          End If
          Set CellSearchByKeywordVerRange = srchRng.Worksheet.Cells((i Mod rows_srchRng) + topRow - 1, Int(i / rows_srchRng) + leftClm)
          multiFindFlag = True
        End If
      Next lp_ary
      If CellSearchByKeywordVerRange Is Nothing Then
        MsgBox srchWrd & " で検索しましたがヒットしませんでした"
        End
      End If
    
    End Function




-----------------------------------------------------------------------------


    Option Explicit
    
    Private wb As Workbook
    Private ws As Worksheet
    
    Sub 列単位の配列存在チェック()
    
      Set wb = ThisWorkbook
      Set ws = wb.Worksheets("存在チェック")
      
      
      Dim i As Long, k As Long
      Dim rng As Range
      
      Dim ary() As Variant
      
      Dim clm_cData As Variant
      Dim rng_lp As Variant
      Dim ary_lp As Variant
      
      Dim ary_chkData() As Variant
      Dim ary_existenceData() As Variant
    
      Set rng = ws.Range("_配列基準セル1").CurrentRegion
      
      i = 0
      For Each clm_cData In rng.Columns
        k = 0
        For Each rng_lp In clm_cData.Cells
          ReDim Preserve ary(k)
          ary(k) = rng_lp
          k = k + 1
        Next rng_lp
      
        ReDim Preserve ary_chkData(i)
        ary_chkData(i) = ary
        i = i + 1
      
      Next clm_cData
      
      Set rng = ws.Range("_配列基準セル2").CurrentRegion
      i = 0
      For Each clm_cData In rng.Columns
        k = 0
        For Each rng_lp In clm_cData.Cells
          If rng_lp <> "" Then
            ReDim Preserve ary(k)
            ary(k) = rng_lp
            k = k + 1
          End If
        Next rng_lp
      
        ReDim Preserve ary_existenceData(i)
        ary_existenceData(i) = ary
        i = i + 1
      
      Next clm_cData
      
    '  For Each ary_lp In ary_chkData
    '    For Each rng_lp In ary_lp
    '
    '    Debug.Print rng_lp
    '
    '    Next rng_lp
    '
    '  Next ary_lp
      Dim arytest As Variant
      arytest = PresenceCheck(ary_chkData, ary_existenceData)
    
    
    
    
    End Sub
    
    
    
    
    Function PresenceCheck(ByVal ary_chkData, ByVal ary_existenceData)
    
      Dim i As Long, k As Long
      Dim flg As Boolean
      Dim ary() As Variant
      
      Dim ary_prsenceCheck(1) As Variant
    
      Dim chD As Variant
      Dim exD As Variant
      Dim chkRslt As Boolean
      
      i = 0
      k = 0
      For Each chD In ary_chkData
      
        flg = False
        For Each exD In ary_existenceData
          chkRslt = CheckArraysEquality(chD, exD)
          If chkRslt = True Then
            flg = True
            Exit For
          End If
        Next exD
        If flg = False Then
          ReDim Preserve ary(i)
          ary(i) = k
          i = i + 1
        End If
      
        k = k + 1
      Next chD
    
      If Not Not ary Then
        ary_prsenceCheck(0) = False
        ary_prsenceCheck(1) = ary
    
      Else
        ary_prsenceCheck(0) = True
      End If
      
      PresenceCheck = ary_prsenceCheck
      
    
    
    End Function
    
    
    Function CheckArraysEquality(ByVal ary1, ByVal ary2)
    
      Dim lp1 As Variant
      Dim lp2 As Variant
      Dim flg As Boolean
      
      If LBound(ary1, 1) <> LBound(ary2, 1) Or UBound(ary1, 1) <> UBound(ary2, 1) Then
        CheckArraysEquality = False
        Exit Function
      End If
    
      For Each lp1 In ary1
        flg = False
        For Each lp2 In ary2
          If lp1 = lp2 Then
            flg = True
            Exit For
          End If
        Next lp2
        If flg = False Then
          CheckArraysEquality = False
          Exit Function
        End If
      Next lp1
      
      CheckArraysEquality = True
    
    
    
    End Function