【マクロ】特定の列にて、ある単語から始まるデータを抽出したいです。

Question

前提・実現したいこと

こんにちは。
Excelのマクロを作成中です。
初心者で調べても全くわからないので、ご教授ください。

P列の「sudo」という単語から始まるデータのみを抽出して、別のExcelファイルにコピーして貼り付けるコードを教えていただきたいです。
業務で、ある列のデータのみを抽出する必要があるのですが、ネットでもやり方がわかりません。

発生している問題・エラーメッセージ

コードがわからない。

該当のソースコード

なし

試したこと

オートフィルター機能も試してみましたが、特定の列のデータのみ抽出するやり方がわかりません。

補足情報（FW/ツールのバージョンなど）

Answer 1

オートフィルタを使った手作業でもよいなら、検索ボックスにsudo*と入れれば対象のもののみ抽出されます。

追記
不本意ですが基本的なコードを載せておきます。

Dim wb As Workbook
Dim ws As Worksheet
Dim r As Long
Set wb = Workbooks.Add                     ' 新規に作る場合
'Set wb = Workbooks.Open "ブックファイル名"  ' 既存ブックを開く場合
Set ws = wb.Worksheets(1)                  ' 貼り付けたいシートを設定
r = 1                                      ' 貼り付け先の開始行
For Each c In Range("P:P")
    If Left(c, 4) = "sudo" Then
        ' A列にコピーしていく
        ws.Cells(r, 1).Value = c
        r = r + 1
    End If
Next

Comments

[Gunjirk]

ご回答ありがとうございます。
できればマクロコードで教えていただきたいです。
抽出したデータのみをコピーして別エクセルに貼り付けたいです。

[rinren]

随分見慣れないと感じられるかもしれません。
きっとマクロの記録でこれまで乗り越えて来られたからだと思います。
ただ、そのマクロ記録には限界がありまして、ワークブックを跨ぐ処理が苦手だったり、汎用性に欠けるので直接自分でコードを書くことになります。
実際に手で書いてくれたコードなので、簡潔で分かりやすいものになっています。
仮にこれをマクロの記録で頑張ってやると、冗長なコード、無駄なコードが生成されますので、かえって学習コストが高くなりますし、方向が間違っています。この書き方に慣れる方がいいと思います。

[rinren]

ちなみにこのコード望む動作をするはずです

[Gunjirk]

ttyp03様
ご丁寧にコードを書いてくださってありがとうございます！！

実際に少し変えて入力してみたところ、毎回新しいブックに貼り付ける形になってしまい、ブックが30ほどできてしまう形になりました。
うまく最初だけ新規ブックに貼り付けをして、二回目以降はその一回目に新規作成したブックに貼り付けるようにするには、どうすればよいでしょうか。
もしよろしければご協力お願い致します。
試してみたコードは以下になります。

For Each c In Range("P:P")
If Left(c, 4) = "sudo" Then
' A列にコピーしていく
ws.Cells(r, 1).Value = c

Dim wb As Workbook
Dim ws As Worksheet
Dim r As Long
Set wb = Workbooks.Add ' 新規に作る場合
Set ws = wb.Worksheets(1) ' 貼り付けたいシートを設定
r = 1 ' 貼り付け先の開始行

r = r + 1
End If
Next

[Gunjirk]

rinren 様
アドバイスありがとうございます。
先週からVBAに触れだした初心者なので、コードの意味も分からない状態です。
自分で作ったコードも載せずに質問する形になってしまい、大変恐縮に思っております。

[ttyp03]

えっと…。
なんでループ内にWorkbooks.Addとかの処理が移動しているんでしょうか…。
ループの外に出してください。
ていうかまずは回答したコードをそのまま試してみてもらえますか？

[Gunjirk]

すみません。
いただいたコードを試したのですが、貼り付けが行われなかったので、先にループをしてしまいました。

新しいブックを作成するだけになってしまいます。。

[ttyp03]

一応手元の環境で動いたものを載せているつもりですが、ダメでしょうか？
今日はもう退社してしまうので、質問がある場合、明日以降の対応になります。
あとは自力でがんばってください。

[ttyp03]

あ、すみません、追記しておきます。
おそらく貼り付けている場所が、対象としているシートではないんだと思います。
対象とするシートに貼り付けるか、For文を次のようにしてみてください。
For Each c In Worksheets("Sheet1").Range("P:P")
"Sheet1"のシート名は適宜修正してください。

[Gunjirk]

何故か白紙のブックを新規作成して終わりになってしまいます。
ループの前に、P列の「sudo」という単語から始まるデータのみを抽出することができれば、できそうだと素人なりに感じたのですが、どうでしょうか。

そうですか、、本日はお疲れ様です。
また明日、ご回答の程お待ちしております。
お忙しい中本日はこんな自分に付き合って下さりありがとうございました。

[arasi]

これうまくいってない、
Workbook.Add
の時点でActiveWorkbookが新規ブックの方になり新規ブックのP列を参照している
なぜこれでうまくいっているかが疑問です

[Gunjirk]

arasi様
ご回答ありがとうございます。
はい、僕も初めに新規ブックを開いてしまうので、無理だと思うのですが、、
如何せん初心者なもので、どう修正したらよいかわからない状態です。

もし修正点などございましたら、ご教授お願い致します。

[ttyp03]

おふた方＞
いえ、例え新規ブックを作っても、明示的にActiveSheet.Rangeなどとしてアクティブシートを指定しない限りは、自身（つまりコードが書かれているシート）を参照するので問題ないのですよ。
昨日18:26に追記したように、コードの置き場所が参照したいP列があるシートではない、またはRangeの参照方法を変えることで対応可能です。

[torisan]

横から失礼、私も最初はうまくいかないと思ったのですが
私含めて、プログラムを標準モジュールに書いていませんか？
シートのモジュール(というのでしょうか？)に書いたら正常に動作しました。

[arasi]

シートモジュールに書いたらうまくいきました
シートモジュールに入れてと書いてよ

[ttyp03]

arasiさん＞
うーん、書かなくても見ればわかると思うのですよ。
わからないなら知識が不足しているだけだと思いますよ。
逆に基本知識が足りないなら「標準モジュールにこのように書いたら動かなかった」や「どこに書けばいいですか？」とか聞いてくれればいいのにと思います。

[arasi]

私の基本知識が足りませんでした。ごめんね

[Gunjirk]

ttyp03さん
シートモジュールに書いたらうまくできました！！
ずっとできなかったことができて、とても嬉しかったです！

また、モジュールに種類があるとも知らずに、手間を取らせてしまい申し訳ございませんでした。
今回の質問のおかげで、たくさん勉強できました。
本当にありがとうございます。

皆様もコメントにてたくさん議論してくださりありがとうございました。
一人でネットで調べるよりも有意義な経験ができました。

Answer 2

最初だけ新規ブックに貼り付けをして、二回目以降はその一回目に新規作成したブックに貼り付けるようにするには、どうすればよいでしょうか。

とのことですので、抽出結果.xlsファイルを作成するならこんな感じかなと思います。初心者様ということで、コメントいっぱいつけておきますので今後の足しにしてください。拡張子やファイル名は適当に変更してください。

Sub addcopy_v2()

'抽出結果ファイルの名前を設定しています。2007以降であれば.xlsxとか使えますね。

Const SaveName As String = "抽出結果.xls"

'↓ここからはこれから使う変数を宣言してます。名称で何となく用途は想像してください。これは書いた人が勝手に決めます。
'といっても何となく想像できる名前にしてあげることが大事です。ほかの人も使うことを考えると・・・。
'私も得意ではないが・・・

Dim BaseWB As Workbook
Dim BaseWS As Worksheet
Dim WriteWB As Workbook
Dim WriteSheet As Worksheet
Dim CheckRange As Range
Dim RangeBuf As Range
Dim LastRow As Long
Dim FSO As Object

'ファイル探す為に、Scripting.FileSystemObjectオブジェクトを使います。
'ほかにも方法はあると思いますが、慣れておいたほうがいいです。
'参照設定(Microsoft scripting runtime)が必要な書き方。
'Dim FSO As New Scripting.FileSystemObject

'参照設定したくないならこの宣言
Set FSO = CreateObject("Scripting.FileSystemObject")

'検索対象のＰ列があるシート捕捉します。thisWorkbookは常にモジュール実行中(このコードが書いてあるほう)のブックを指します。そのワークシートインデックスが１のシートを捕捉。つまりBaseWbって分かりやすいように自分で決めた変数に格納して、後で色々いじくってやろうって魂胆です。
Set BaseWS = ThisWorkbook.Worksheets(1)

'上記で捕捉したBaseWSを使って、BaseWS.Range("P:P")と書くと、ThisWorkbook.Worksheets(1).Range("P:P")と同じ意味になります。
'オブジェクトは階層を持っています。アプリケーション→ブック→シート→レンジって感じです。
'辿るように操作したいセルにたどり着ければほぼ目的は達成できます。

'↓heckRangeという変数に捕捉したワークブックのレンジを格納します。
Set CheckRange = BaseWS.Range("P:P")

'ご希望通り、２回目は追記(?)もしくは上書き動作になるように。抽出結果ファイルを自分と同じディレクトリで探します
If FSO.FileExists(ThisWorkbook.Path & "\" & SaveName) = True Then
   
   'もしあればそのブックを開きます
   Set WriteWB = Workbooks.Open(ThisWorkbook.Path & "\" & SaveName)
   
   'sheet1を捕捉します。
   Set WriteSheet = WriteWB.Worksheets(1)
Else
   'なければ新規ブックを作成します
   Set WriteWB = Workbooks.Add
   
   'ActiveSheetを補足します。新規作成時においてsheet1を捕捉することになります。
   Set WriteSheet = ActiveSheet
End If

'上記の処理で捕捉した抽出シートの最終行を探します。
LastRow = WriteSheet.Cells(Rows.Count, 1).End(xlUp).Row
If LastRow <> 1 Then LastRow = LastRow + 1

'上書きならここで何らかの削除処理(シートごと消すのか、最終行から範囲を割り出して消すのか)今回は後者を書いておきます。
'必要であればコメントを解除してください
'=========================
'With WriteSheet
'   .Range(.Cells(1, 1), .Cells(LastRow, 1)).ClearContents
'End With
'   LastRow = 1
'=========================

'検索対象のＰ列があるシートの親、つまりブックをアクティブにします
BaseWS.Parent.Activate

'検索範囲をループします。
For Each RangeBuf In CheckRange
   
   'もし検索中のセルの先頭の4文字が"sudo"だったら、抽出シートの最終行に書き込みます。
   If Left(RangeBuf.Value, 4) = "sudo" Then
      WriteSheet.Cells(LastRow, 1).Value = RangeBuf.Value
      
      '書き込み位置を次の位置にずらします。
      LastRow = LastRow + 1
   End If

Next RangeBuf

'保存しますか?的なメッセージを止めます。
Application.DisplayAlerts = False
WriteWB.SaveAs Filename:=ThisWorkbook.Path & "\" & SaveName
WriteWB.Activate

'保存しますか?的なメッセージを止めたのを元に戻します。処理実行後のアプリケーションの動作に影響が残るからです。
Application.DisplayAlerts = True

End Sub

Comments

[Gunjirk]

rinrenさん
コメントまでご丁寧にありがとうございます！
とても分かりやすいので、今後のためにできるだけ理解できるように頑張ります！
まさか、見ず知らずの他人のためにここまでしてくださる人がいるとは思わず、とても感動しています。
本当にありがとうございました。

[Gunjirk]

たびたびすみません、いただいたコードを試すと、貼り付けはできるのですが、2行目から貼り付けられてしまい、1行目が空欄になってしまいます。
考えられる要因など御座いましたら、教えていただきたいです。

[Gunjirk]

LastRow = WriteSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
自分で考えてみて、上記の+ 1を消してみたら、直りました。
この対応で問題ないか、よろしければご確認お願い致します。

[rinren]

そうですね。なぜそうしたかというと。列名を書きたい場合もあるか思いまして、そうしておきました。
コードの意味が分かるようになると、自分でいろいろできますね。頑張ってください。

[Gunjirk]

ご返信と励ましのお言葉ありがとうございます！
自分の成長のために、teratailをどんどん活用していきたいと思います！
今後とも宜しくお願い致します。

[rinren]

あ、ちなみに+1消すだけだと、二回目の実行結果が前回とかぶります。
lastrowが1以外だったら+1とするif文を追加するのが簡単かもしれません。

[Gunjirk]

ご回答の修正までしていただき、ありがとうございます！