正規表現による検索２しゅるい
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