EXCEL VBAについて質問です。良い回答は100~300ptを差し上げます。

下に記載しているソースは、シート名と同じ名前をセルから検索してます。
その際、あいまい検索も可能としたいのです。

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

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

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

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

回答の条件
  • 1人10回まで
  • 登録:2012/01/17 16:59:42
  • 終了:2012/01/17 18:58:24

ベストアンサー

id:kodairabase No.2

kodairabase回答回数661ベストアンサー獲得回数802012/01/17 18:10:51

ポイント300pt

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

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
id:japan-nan

ありがとうございました。

2012/01/17 18:57:42

その他の回答(1件)

id:taknt No.1

きゃづみぃ回答回数13539ベストアンサー獲得回数11982012/01/17 17:28:17

ポイント10pt

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

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
id:kodairabase No.2

kodairabase回答回数661ベストアンサー獲得回数802012/01/17 18:10:51ここでベストアンサー

ポイント300pt

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

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
id:japan-nan

ありがとうございました。

2012/01/17 18:57:42

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません