Excel VBA質問箱 IV

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

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


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

3721 / 76735

←次へ　｜　前へ→


	【78643】Re:どうかよろしくお願いします

γ - 16/12/3(土) 14:52 -


	引用なし

	パスワード

βさんのお陰で、大分明確になりました。
ありがとうございました。

関数でということなので、そちらは皆様にお願いすることとして、
番外で、VBAで遊んで見ました。
こんなことなんでしょうか。

【インデックスがずれていたので再掲します】
　
Sub Sample()
　　Dim re　As Object
　　Dim m　 As Object
　　Dim r　 As Range
　　Dim s　 As String
　　Dim i　 As Long
　　
　　'正規表現を利用する準備
　　Set re = CreateObject("VBScript.RegExp")
　　re.Pattern = "09*1"　　 ' 0に1が続く場合。(間に9があっても可)
　　　
　　Set r = Intersect([A1].CurrentRegion, Columns("A:X"))
　　r.Interior.Pattern = xlNone　　　　 ' 塗りつぶしを解除
　　
　　For i = 2 To r.Rows.Count
　　　　s = Join(Application.Index(r.Rows.Item(i).Value, 0), "")
　　　　Set m = re.Execute(s)
　　　　If m.Count > 0 Then　　　　　　 ' マッチした場合
　　　　　　Cells(i, "Y").Value = 1
　　　　　　Cells(i, "Z").Value = Cells(1, m(0).firstindex + 1).Value
　　　　　　Cells(i, "AA").Value = Cells(1, m(0).firstindex + m(0).Length).Value
　　　　　　With Cells(i, m(0).firstindex + 1).Interior
　　　　　　　　.Pattern = xlSolid
　　　　　　　　.PatternColorIndex = xlAutomatic
　　　　　　　　.Color = 65535　　　　　'黄色に塗りつぶす
　　　　　　End With
　　　　Else　　　　　　　　　　　　　　'マッチしなかった場合
　　　　　　Cells(i, "Y").Value = 0
　　　　　　Cells(i, "Z").ClearContents
　　　　　　Cells(i, "AA").ClearContents
　　　　End If
　　Next
End Sub

0 hits

▼

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