質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

1回答

3349閲覧

VBAでフィルターをかけて、検出対象を別シートへコピーしたい

linx_0415

総合スコア8

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

0クリップ

投稿2017/12/21 10:16

###前提・実現したいこと
ログを確認するVBA

シート1 ログ全文
シート2 単語1
シート3 単語2
シート4 単語3

①ログ全文シートに貼り付けられたログ(A列のみ、空白行有り)に「単語1」でフィルターをかける
②検出された行をコピーして、シート2「単語1」へ貼り付ける
③シート1「ログ全文」へ戻り、検出されている行に色をつける
④”単語2”でログをかけなおす
⑤単語が含まれている行が検出された場合のみ、②③同様の作業(シートのみシート3「単語2」になる)を行う。
検出されなかった場合は何も行わない。
⑥”単語3”でログをかけなおす
⑦⑤と同様。(シートのみシート4「単語3」になる)
⑧ファイルを別名保存(保存先:デスクトップ)する

###発生している問題・エラーメッセージ
ネット上で探していろいろと試しましたが、
・実行時エラー 438
・実行時エラー 1004
が発生してしまい、同様に調べて原因調査を行いましたが、解決できませんでした。

###補足情報(言語/FW/ツール等のバージョンなど)
Excel 2010

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

imihito

2017/12/21 13:32

可能であれば使用したコードを質問に追記してください。
linx_0415

2017/12/22 01:41

すみません、昨日の段階であきらめて消してしまいました
guest

回答1

0

ベストアンサー

上記要件に即してプログラムを作成しました。
検索単語をシート数の上限まで設定できるようにしたり、
ログが肥大化した際でも高速に処理ができるように工夫してあります。
何か問題があればコメントください。

VBA

1Option Explicit 2 3' 「シート1 ログ全文」シートのシート名 4Private Const SHEET_NAME_LOG_MAIN As String = "ログ全文" 5 6' ログのフィルターを実施 7Public Sub FilterLogs() 8 9 ' 変数宣言 10 Dim book As Workbook 11 Dim sheet As Worksheet 12 Dim logSheet As Worksheet 13 Dim searchWords As Collection 14 Dim searchWord As Variant 15 Dim matchedLogs As Collection 16 17 ' 処理対象ブック取得 18 Set book = ThisWorkbook 19 20 ' 検索文字列を取得 21 ' また検索結果出力シートの初期化も実施 22 ' ※シート名を走査し、シート名が SHEET_NAME_LOG_MAIN 以外の全シート名を 23 '  検索文字列と認識します。これにより、何項目でも検索することができます 24 Set searchWords = New Collection 25 For Each sheet In book.Worksheets 26 If sheet.Name <> SHEET_NAME_LOG_MAIN Then 27 sheet.Cells.Clear 28 searchWords.Add sheet.Name 29 End If 30 Next 31 32 ' 「シート1 ログ全文」シート取得 33 Set logSheet = book.Worksheets(SHEET_NAME_LOG_MAIN) 34 35 ' A1セルにフォーカスをあてる(処理後にきれいに見えるため) 36 logSheet.Activate 37 logSheet.Cells(1, 1).Select 38 39 ' 全検索項目を検索 40 For Each searchWord In searchWords 41 42 ' 検索を実施 43 Set matchedLogs = SearchMatchedCell(logSheet, CStr(searchWord)) 44 45 ' 見つかった場合はシートに吐き出す 46 If matchedLogs.Count > 0 Then 47 48 OutputMatchedLogs book.Worksheets(searchWord), matchedLogs 49 50 ' 見つからなかった場合は処理終了 51 Else 52 53 MsgBox "「" & searchWord & "」が含まれるログが存在しませんでした " & vbLf & "処理を終了します", vbInformation + vbOKOnly, "処理終了" 54 55 ' ブックをデスクトップに別名保存 56 If Not Save(book) Then 57 MsgBox "保存に失敗しました。手動で保存してください", vbExclamation + vbOKOnly, "保存失敗" 58 End If 59 60 Exit Sub 61 62 End If 63 64 Next 65 66 ' ブックをデスクトップに別名保存 67 If Not Save(book) Then 68 MsgBox "保存に失敗しました。手動で保存してください", vbExclamation + vbOKOnly, "保存失敗" 69 End If 70 71 ' メッセージ出力 72 MsgBox "処理が完了しました", vbInformation + vbOKOnly, "処理終了" 73 74End Sub 75 76' 別保存実行 77Private Function Save(ByRef book As Workbook) As Boolean 78 79 ' 変数宣言 80 Dim path As String 81 82 ' 保存パス取得 83 With CreateObject("WScript.Shell") 84 path = .SpecialFolders("Desktop") & "\" & Left(book.Name, InStrRev(book.Name, ".") - 1) & "_検索後" 85 End With 86 87 ' 保存実行 88 On Error Resume Next 89 book.SaveAs Filename:=path, FileFormat:=xlOpenXMLWorkbookMacroEnabled 90 91 ' 保存成功有無を返却 92 If Err.Number <> 0 Then 93 Save = False 94 Else 95 Save = True 96 End If 97 98 On Error GoTo 0 99 100End Function 101 102' 検索結果マッチした文字列を出力 103Private Sub OutputMatchedLogs(ByRef sheet As Worksheet, ByRef matchedLogs As Collection) 104 105 ' 変数宣言 106 Dim matchedLog As Variant 107 Dim outputRow As Long 108 109 ' シートを初期化 110 sheet.Cells.Clear 111 112 ' 出力行初期化 113 outputRow = 0 114 115 ' 全検索結果を走査 116 For Each matchedLog In matchedLogs 117 118 ' 出力行を最新化 119 outputRow = outputRow + 1 120 121 ' 検索結果を出力 122 sheet.Cells(outputRow, 1).Value = CStr(matchedLog) 123 124 Next 125 126End Sub 127 128' 全セルに対して検索対象文字が含まれるかどうかを検索し含まれる場合にはセル色を変更 129' 検索対象文字が含まれるセルの文字列を Collection に詰めて返却 130Private Function SearchMatchedCell(ByRef sheet As Worksheet, ByRef word As String) As Collection 131 132 ' 変数宣言 133 Dim datas As Variant 134 Dim cell As Range 135 Dim matchedLogs As Collection 136 Dim firstRow As Long 137 Dim firstColumn As Long 138 Dim i As Long, j As Long 139 140 ' オブジェクト初期化 141 Set matchedLogs = New Collection 142 143 With sheet.UsedRange 144 145 ' 全ログを取得 146 datas = .Cells 147 148 ' ログ開始行取得 149 firstRow = .Cells(1).Row 150 151 ' ログ開始列取得 152 firstColumn = Cells(1).Column 153 154 End With 155 156 ' 全セル走査 157 For i = LBound(datas, 1) To UBound(datas, 1) 158 For j = LBound(datas, 2) To UBound(datas, 2) 159 If datas(i, j) Like "*" & word & "*" Then 160 sheet.Cells(firstRow + i - 1, firstColumn + j - 1).Interior.ColorIndex = 3 161 matchedLogs.Add datas(i, j) 162 End If 163 Next 164 Next 165 166 ' 結果返却 167 Set SearchMatchedCell = matchedLogs 168 169End Function 170

投稿2018/01/06 14:35

yamashita_yuich

総合スコア316

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問