質問: ### 前提・実現したいこと こんにちは。 Excelのマクロを作成中です。 初心者で調べても全くわからないので、ご教授ください。 P列の「sudo」という単語から始まるデータのみを抽出して、別のExcelファイルにコピーして貼り付けるコードを教えていただきたいです。 業務で、ある列のデータのみを抽出する必要があるのですが、ネットでもやり方がわかりません。 ### 発生している問題・エラーメッセージ ``` コードがわからない。 ``` ### 該当のソースコード ``` なし ``` ### 試したこと オートフィルター機能も試してみましたが、特定の列のデータのみ抽出するやり方がわかりません。 ### 補足情報(FW/ツールのバージョンなど)
回答: > > 最初だけ新規ブックに貼り付けをして、二回目以降はその一回目に新規作成したブックに貼り付けるようにするには、どうすればよいでしょうか。 > > > とのことですので、抽出結果.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") '検索対象のP列があるシート捕捉します。thisWorkbookは常にモジュール実行中(このコードが書いてあるほう)のブックを指します。そのワークシートインデックスが1のシートを捕捉。つまりBaseWbって分かりやすいように自分で決めた変数に格納して、後で色々いじくってやろうって魂胆です。 Set BaseWS = ThisWorkbook.Worksheets(1) '上記で捕捉したBaseWSを使って、BaseWS.Range("P:P")と書くと、ThisWorkbook.Worksheets(1).Range("P:P")と同じ意味になります。 'オブジェクトは階層を持っています。アプリケーション→ブック→シート→レンジって感じです。 '辿るように操作したいセルにたどり着ければほぼ目的は達成できます。 '↓heckRangeという変数に捕捉したワークブックのレンジを格納します。 Set CheckRange = BaseWS.Range("P:P") 'ご希望通り、2回目は追記(?)もしくは上書き動作になるように。抽出結果ファイルを自分と同じディレクトリで探します 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 '========================= '検索対象のP列があるシートの親、つまりブックをアクティブにします 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 ```