1251621428 マクロ作成をお願いいたします

【1】シートが2つあります。
1「NEWカテ」シート
A列、B列には見出しがついていたりついていなかったりします/文字列
C列には5万行越えで分類番号があります/数値
D列にはツリーがすべてあります。例 食物 > 果物 > 柑橘類 > みかん

2「選択」というシートがあります。

【2】マクロ実行で(どのシートを開いていたとしても、NEWカテシートにて)
インプットBOXで、添付した画像のように、and/or /not検索ができるようします。
BOXに数値や文字列を入れると、B列、A列、D列の順に検索し、ヒットした行のA列~D列をそのまま「選択シート」A1~D1から順に下に貼付てほしいのです。

ヒットする行は普段5万のうち、1~多くても50程度迄が多いです。時間希望は1~5秒くらいが希望ですが、もし時間がかかるのであれば、節約するアドバイスをいただけると幸いです。
よろしくお願いいたします。

回答の条件
  • 1人3回まで
  • 登録:2009/08/30 17:37:10
  • 終了:2009/08/31 10:25:21

ベストアンサー

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912009/08/31 00:54:35

ポイント100pt

とりあえず仕様通り(?)に作ってみました。

実行時間はどのくらいかかるか不明ですが、実用的な時間でないようならポイント不要です。


内容は以下の構成を想定しています。

ワークシート

  検索シート名・・・NEWカテ
  結果シート名・・・結果シート

入力用ユーザフォーム

    AND 検索語・・・・ANDKeyWord
    OR  検索語・・・・ORKeyWord
    NOT 検索語・・・・NOTKeyWord

  検索ボタン・・・・SearchButton
  キャンセルボタン・CancelButton

ユーザフォームのコード

'----------------------------------------------------
Private Sub SearchButton_Click()
'----------------------------------------------------
    If (ANDKeyWord = "" And ORKeyWord = "") _
    Or (ANDKeyWord <> "" And ORKeyWord <> "") Then
        MsgBox "AND検索 か OR検索 のどちらか一つを指定してください。"
        Exit Sub
    End If
    searchKeyWords ANDKeyWord, ORKeyWord, NotKeyWord
    Unload Me
End Sub

'----------------------------------------------------
Private Sub CancelButton_Click()
'----------------------------------------------------
    Unload Me
End Sub

標準モジュール

Option Explicit
'------------------------------------------------------------------------

Const SrcWSName = "NEWカテ"
Const DstWSName = "結果シート"

'------------------------------------------------------------------------
Sub CallSearch()
'------------------------------------------------------------------------
    SerchForm.Show
End Sub

'------------------------------------------------------------------------
Sub searchKeyWords(AndWords, OrWords, NotWords)
'------------------------------------------------------------------------
    Dim andFlag As Boolean
    Dim keyWords As String
    If AndWords <> "" Then
        keyWords = Trim(Replace(AndWords, " ", " "))
        andFlag = True
    ElseIf OrWords <> "" Then
        keyWords = Trim(Replace(OrWords, " ", " "))
        andFlag = False
    End If
    
    Dim ll As Long
    Do
        ll = Len(keyWords)
        AndWords = Replace(keyWords, "  ", " ")
    Loop While ll < Len(keyWords)
    
    Dim notKeyWords As String
    notKeyWords = Trim(Replace(NotWords, " ", " "))
    Do
        ll = Len(notKeyWords)
        AndWords = Replace(notKeyWords, "  ", " ")
    Loop While ll < Len(notKeyWords)
    
    findAndAdd "B", Split(keyWords, " "), Split(notKeyWords, " "), andFlag, True
    findAndAdd "A", Split(keyWords, " "), Split(notKeyWords, " "), andFlag
    findAndAdd "D", Split(keyWords, " "), Split(notKeyWords, " "), andFlag
    Worksheets(DstWSName).Activate
End Sub

'------------------------------------------------------------------------
Sub findAndAdd(searchColumn As String, keyWords, notKeyWords, andFlag As Boolean, Optional clearSheet As Boolean = False)
'------------------------------------------------------------------------
    Dim objDic As Object
    Set objDic = CreateObject("Scripting.Dictionary")

    Dim c As Long
    Dim n As Long
    Dim keyWord
    Dim , fRange As String * testRange As Range
    searchRange As String * Dim
    Set searchRange = Worksheets(SrcWSName).Columns(searchColumn)
    
    '--- 検索されたものを追加
    For Each keyWord In keyWords
        Set testRange = searchRange.Find(What:=keyWord, LookAt:=xlPart)
        If Not testRange Is Nothing Then
            Set fRange = testRange
            Do
                If objDic.Exists(testRange.Row) Then
                    objDic.Item(testRange.Row) = objDic.Item(testRange.Row) + 1
                Else
                    objDic.Add testRange.Row, 0
                End If
                Set testRange = searchRange.FindNext(testRange)
            Loop While fRange.Address <> testRange.Address
        End If
    Next
    
    '--- 検索結果のキー配列
    Dim myKey
    myKey = objDic.Keys
    
    '--- Not で指定されたものを削除
    Dim NotWord
    Dim i As Long
    For Each NotWord In notKeyWords
        For i = 0 To objDic.count - 1
            If InStr(Worksheets(SrcWSName).Cells(myKey(i), searchColumn).Value, NotWord) > 0 Then
                objDic.Remove myKey(i)
            End If
        Next
    Next

    '---結果を表示
    myKey = objDic.Keys
    Dim writeRow As Long
    With Worksheets(DstWSName)
        If clearSheet = True Then
            Worksheets(DstWSName).Columns("A:D").Clear
            writeRow = 1
        Else
            writeRow = Application.WorksheetFunction.Max( _
                .Range("A" & Rows.count).End(xlUp).Row, _
                .Range("B" & Rows.count).End(xlUp).Row, _
                .Range("C" & Rows.count).End(xlUp).Row, _
                .Range("D" & Rows.count).End(xlUp).Row) + 1
        End If
        .Cells(writeRow, "A") = searchColumn & "列の検索結果"
        .Cells(writeRow, "A").Resize(1, 4).Merge
        .Cells(writeRow, "A").Resize(1, 4).Interior.ColorIndex = 35
        writeRow = writeRow + 1
        For i = 0 To objDic.count - 1
            If andFlag = True Then
                If objDic.Item(myKey(i)) = UBound(keyWords) Then
                    Worksheets(SrcWSName).Cells(myKey(i), "A").Resize(1, 4).Copy Destination:=.Cells(writeRow, "A").Resize(1, 4)
                    writeRow = writeRow + 1
                End If
            Else
                Worksheets(SrcWSName).Cells(myKey(i), "A").Resize(1, 4).Copy Destination:=.Cells(writeRow, "A").Resize(1, 4)
                writeRow = writeRow + 1
            End If
        Next i
    End With
End Sub

データは空ですが上記の内容のファイルをアップしました。

http://d.hatena.ne.jp/Mook/20090830

先頭シートにデータをコピーして CallSearch 実行してみてください。


ちなみにアップしたファイルでは、Ctl+Shift+S で起動するようにオプション設定しています。

  • id:SALINGER
    これはマクロを使わなくてもそれに近いことがフィルタオプションの設定でできます。
    http://allabout.co.jp/computer/msexcel/closeup/CU20070905A/index2.htm
    ただし、一番上に見出しが必要なことと、抽出先が同じシートでなくてはいけないこと。
    これは工夫次第でなんとかなります。
    問題なのが列ごとに設定する検索条件でしょうか。
    ある程度柔軟にはできますが、質問にあるようなことはできないような。
    仮にVBAでこれを作った場合、5万行を5秒とはいかないような気がします。
  • id:naranara19
    いつもありがとうございます!URlみさせていただきました。時間的に厳しいものがありまして、マクロでお願いしたいのです。仕様を変えないと難しそうでしょうか・・。
  • id:Mook
    理由は分かりませんが、コードがおかしくなっていました。
    変数宣言の部分を下記のように修正してください。

    Dim objDic
    Set objDic = CreateObject("Scripting.Dictionary")

    Dim keyWord
    Dim fRange As Range
    Dim testRange As Range
    Dim searchRange As Range
    Set searchRange = Worksheets(SrcWSName).Columns(searchColumn)

    ファイルも更新しています。
  • id:naranara19
    完璧に動きました。「B列の結果」「A列の結果」・・などと色付けで出る仕様にしてくださったのが大変見やすく助かります。薄緑も良い感じです。時間も期待通りで早かったです!

    また、はてなの日記にのせてくださったので、やりとりが何度かできて、ファイルも受け取ることができて大変こちらとしては助かりました。

    また、面倒なVBAを組んでくださって、「実用的な時間でないようならポイント不要です。」なんて、太っ腹すぎて感激しました。本当にありがとうございます。

    今後も何卒よろしくお願いいたします。

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

トラックバック

  • Mookノート 2009-08-31 00:51:08
    **[はてな]はてなダイアリーの活用法 ファイルの公開 はてなのプログラミング関連の質問に答えていて、文章で書くことが面倒でいっそのことファイルを送りたいと思うことがたまにある
  • はてなダイアリーの活用法 **ファイルの公開 はてなのプログラミング関連の質問に答えていて、文章で書くことが面倒でいっそのことファイルを送りたいと思うことがたまにある。 今回の
「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

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

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