Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

3718 / 76735

←次へ　｜　前へ→


	【78646】Re:特定の数値パターンを調べるには？

γ - 16/12/4(日) 11:32 -


	引用なし

	パスワード

βさんからのご指摘を踏まえて、改定版を載せておきます。

・対象となる範囲は自由。
　・A1から始まらなくてもよいし、行列の大きさを問わない。
　・ただし、周囲を空白ないし行列境界で囲まれたひとつながりの領域であること。
　・その領域の一部にカーソルをおいた状態で、マクロを実行させます。

・結果の書込範囲は指定不要。
　その領域の右の空白一列は空けて、その次の列から自動で書き込みます。

・開始の0セルを黄色で塗りつぶし、終了の1セルを緑で塗りつぶします。（可視性）

------------------
Sub Sample2()
　　Dim re　　　 As Object
　　Dim m　　　　As Object
　　Dim myTable　As Range
　　Dim myHeader As Range
　　Dim s　　　　As String
　　Dim i　　　　As Long
　　Dim lastCol　As Long
　　Dim pos0　　 As Long
　　Dim pos1　　 As Long
　　
　　If TypeName(Selection) <> "Range" Or IsEmpty(Selection(1)) Then
　　　　MsgBox "対象となる範囲の一部にカーソルを置いて下さい"
　　　　Exit Sub
　　End If
　　
　　Application.ScreenUpdating = False
　　
　　'正規表現を利用する準備
　　Set re = CreateObject("VBScript.RegExp")
　　'マッチパターンの指定
　　re.Pattern = "09*1"　 '0に1が続く場合。(間に任意個の9があっても可)

　　Set myTable = Selection.CurrentRegion
　　Set myHeader = myTable.Rows(1).Cells
　　
　　lastCol = myTable.Columns.Count
　　myTable.Interior.Pattern = xlNone　 ' 塗りつぶしをいったん解除

　　For i = 2 To myTable.Rows.Count
　　　　s = Join(Application.Index(myTable.Rows.Item(i).Value, 0), "") '連結文字列に
　　　　Set m = re.Execute(s)　 '正規表現によるマッチの実行
　　　　If m.Count > 0 Then　　 ' マッチした場合
　　　　　　pos0 = m(0).firstindex + 1　　　　　　　'0　の位置
　　　　　　pos1 = m(0).firstindex + m(0).Length　　'1　の位置
　　　　　　myTable(i, lastCol + 2).Value = 1
　　　　　　myTable(i, lastCol + 3).Value = myHeader(1, pos0).Value
　　　　　　myTable(i, lastCol + 4).Value = myHeader(1, pos1).Value
　　　　　　myTable(i, pos0).Interior.Color = vbYellow '黄色に塗りつぶす
　　　　　　myTable(i, pos1).Interior.Color = vbGreen　'緑色に塗りつぶす
　　　　Else　　'マッチしなかった場合
　　　　　　myTable(i, lastCol + 2).Value = 0
　　　　　　myTable(i, lastCol + 3).ClearContents
　　　　　　myTable(i, lastCol + 4).ClearContents
　　　　End If
　　Next
　　Application.ScreenUpdating = True
End Sub

0 hits

▼

【78637】どうかよろしくお願いします エクセルの素人 16/12/2(金) 23:52