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

マクロ作成をお願いいたします
【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秒くらいが希望ですが、もし時間がかかるのであれば、節約するアドバイスをいただけると幸いです。
よろしくお願いいたします。

1251621428
●拡大する


●質問者: naranara19
●カテゴリ:コンピュータ 科学・統計資料
✍キーワード:?D A1 BOX みかん アドバイス
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● Mook
●100ポイント ベストアンサー

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

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


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

ワークシート

  検索シート名・・・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 で起動するようにオプション設定しています。

関連質問


●質問をもっと探す●



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