人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

EXCEL VBAについて質問です。良い回答は100?300ptを差し上げます。
下に記載しているソースは、シート名と同じ名前をセルから検索してます。
その際、あいまい検索も可能としたいのです。

http://tminamiya.blog83.fc2.com/blog-category-12.html

例えば、
シート名が「コインランドリー」の場合
今は、セルに「コインランドリー」があったら抽出しますが、
「コインランドリー?」も「コインランドリー?」も
「コインランドリー」シートへ抽出対象としたい。

形式は:
名前の後に???が対象です。[○△■,○△■?,○△■?,...]

ソースでの回答を希望します。

●質問者: japan-nan
●カテゴリ:ビジネス・経営 コンピュータ
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● きゃづみぃ
●10ポイント

検索して抽出するだけのマクロです。

Sub Macro1()

 シート名 = "シート名"
 キー文字列 = " ????????????????????"
 For i = 1 To 21
 b = シート名 & Trim(Mid(キー文字列, i, 1))
 Set a = Cells.Find(What:=b, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
 xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
 , MatchByte:=False, SearchFormat:=False)
 
 If Not (a Is Nothing) Then
 Debug.Print (b & "が見つかったよ " & a)
 End If
 Next i

End Sub

2 ● kodairabase
●300ポイント ベストアンサー

ご質問のあいまい検索は★印の部分に当たります。
正規表現という手法を使っています。
お試しください。

Sub mySearch(srcWB As Workbook, prefName)
 Dim productName As String
 Dim wsName
 Dim dstWS As Worksheet
 Dim dstRow As Long
 Dim r As Long
 Dim re As Object
 Dim remat As Variant
 Dim pat As String

 Set re = CreateObject("VBScript.RegExp")
 pat = "^(.+)([????????????])$"  '★ここを変更してください

 For Each wsName In Array("大型","計")
 With srcWB.Worksheets(wsName)

 For r = 4 To Rows.Count
 If wsName = "計" Then
 productName = .Cells(r + 4, "B")
 Else
 productName = .Cells(r, "D")
 End If

 If productName = "" Then Exit For
 On Error Resume Next
 With re
 .Pattern = pat
 .IgnoreCase = True
 .Global = True
 Set remat = .Execute(productName)
 If remat.Count > 0 Then productName = remat(0).subMatches(0)
 End With
 Set dstWS = ThisWorkbook.Worksheets(productName)
 On Error GoTo 0

 If Not dstWS Is Nothing Then
 If wsName = "大型" Then
 dstRow = dstWS.Cells(Rows.Count, "B").End(xlUp).Row + 1
 dstWS.Cells(dstRow, "B").Value = prefName
 dstWS.Cells(dstRow, "C").Value = productName
 dstWS.Cells(dstRow, "E").Value = .Range("J2")
 dstWS.Cells(dstRow, "F").Value = .Cells(r, "H")
 Set dstWS = Nothing '// 一応おまじない
 End If

 If wsName = "計" Then
 dstRow = dstWS.Cells(Rows.Count, "B").End(xlUp).Row + 1
 dstWS.Cells(dstRow, "B").Value = prefName
 dstWS.Cells(dstRow, "C").Value = productName
 dstWS.Cells(dstRow, "E").Value = .Range("L5")
 Set dstWS = Nothing '// 一応おまじない
 End If

 End If
 Next
 End With
 Next
 Set re = Nothing
End Sub

japan-nanさんのコメント
ありがとうございました。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ