[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『必要な列のみ抽出したい』（いちまつ）
こんにちは。
毎週定期で送付されるファイルで、「必要な列のみデータを抽出し他のブックに転記する。」という作業をしたく、ネットで検索したVBAのコマンドでマクロを作りましたが上手く出来ません。
送付されるファイルは毎週10ファイルあり、列の数は全ての項目に該当データがあれば50列、該当データが無ければ左詰めとなるので50列以下となり、列番号が不確定です。
列のタイトルは固定なので、そちらを使い関数やVBAで処理出来る方法がありましたらご教授下さい。
よろしくお願い致します。
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
＞列のタイトルは固定なので、そちらを使い関数やVBAで処理出来る方法
関数ではありませんが、フィルタオプションの利用を検討されてみてはいかがですか？
（マクロ化も可能です。）
（もこな２） 2021/11/30(火) 18:52
（マナ） 2021/11/30(火) 18:55
返信いただき、ありがとうございます。
雑な質問の仕方で申し訳ありませんでした。
作成した内容は以下のとおりです。
3行目のエラーで既に進めなくなってしまいました。
また、先の質問で別ブックに抽出したいと書きましたがネットで見つけられず
別シートに抽出する。という文にしております。
Sub GetColumnsWithKeywords()
Dim keywords As string
keywords = InputBox("Title","Author","Publication Title","Volume","Issue","Pagination","Abstract","Document URL")
If keywords = "" Then:Exit Sub
Dim ws1 As Worksheet
Set ws1 = Worksheets.("Sheet1")
Dim ws2 As Worksheet
Set ws2 = Worksheets.Add(After:=ws1)
ws2.Name = "New Sheet"
Dim k As long
k = 1
Dim cmax As Long
cmax = ws1.UsedRange.Raws.Count
Dim rng As Range
Dim keyword As Variant
Dim i As Long
For i = 1 To ws1.UsedRange.Columns.Count
Set rng = ws1.Range("A1:A" & cmax).Offset(0, i - 1)
Debug.Print rng.Address
For Each keyword In Split(keywords, ("Title","Author","Publication Title","Volume","Issue","Pagination","Abstract","Document URL")
If Not rng.Find(keyword) Is Nothing Then
ws1.Colmns(i).Copy (ws2.Columns(k))
k = k + 1
Exit For
End Sub
よろしくお願い致します。
（いちまつ） 2021/12/01(水) 14:46
InputBox には、application.InputBox と InputBox関数の２つあります。
その違いでは？
（マカロニグラタン） 2021/12/01(水) 14:58
keywords = InputBox("Title","Author","Publication Title","Volume","Issue","Pagination","Abstract","Document URL")
（わからん） 2021/12/01(水) 15:37
InputBoxの中に書かれていたのはコピーしたい列タイトルかなと思い、 ざっくり修正してみました。動作確認はしていませんので参考程度に。 Ifは終わりにEnd Ifを入れる、Forは終わりにNextを入れるようにしましょう。
Sub GetColumnsWithKeywords()
Dim keywords As Variant
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Long, j As Long, k As Long, cmax As Long
Dim rng As Range
'列タイトルを配列にセット
keywords = Array("Title", "Author", "Publication Title", "Volume", "Issue", "Pagination", "Abstract", "Document URL")
'ws1にSheet1をセット
Set ws1 = Worksheets("Sheet1")
'ws2にSheet1の後ろに追加した新規シートをセット
Set ws2 = Worksheets.Add(After:=ws1)
'ws2の名前を「New Sheet」に変更
ws2.Name = "New Sheet"
'ws1の最終行を取得
cmax = ws1.UsedRange.Rows.Count
'ws1の1列目から最終列までループ
k = 1
For i = 1 To ws1.UsedRange.Columns.Count
'ws1のi番目列の1行目〜最終行の範囲をrngにセット
Set rng = ws1.Range("A1:A" & cmax).Offset(0, i - 1)
'上記で取得したアドレスをイミディエイトに出力
Debug.Print rng.Address
'keywords配列を最初から最後までループ
For j = LBound(keywords) To UBound(keywords)
'rngの範囲内にj番目の列タイトルがあるか
If Not rng.Find(keywords(j)) Is Nothing Then
'ws1のi列をws2のk列にコピー
ws1.Columns(i).Copy (ws2.Columns(k))
'kを次の列番号にする
k = k + 1
'keywords配列のループを抜ける
Exit For
End If
Next
Next
End Sub
以下は別ブックに保存するためのヒントです。
'新規ブックを作成し名前をつけて保存 Sub NewWorkbookSave()
Dim wb2 As Workbook
Dim ws2 As Worksheet
'新規ブックを作成しwb2にセット
Set wb2 = Workbooks.Add
'新規ブックの1シート目をws2にセット
Set ws2 = wb2.Sheets(1)
'wb2をデスクトップに「NewWorkbook.xlsx」という名称で保存
wb2.SaveAs "C:\Users\★★★\Desktop\NewWorkbook.xlsx"
End Sub （さくさくアジフライ） 2021/12/01(水) 15:55
Sub GetColumnsWithKeywords()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim keyword As Variant
Dim i As Variant
Dim k As Long
'Dim keywords As String
'keywords = InputBox("Title", "Author", "Publication Title", "Volume", "Issue", "Pagination", "Abstract", "Document URL")
'If keywords = "" Then Exit Sub
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets.Add(After:=ws1)
ws2.Name = "New Sheet"
'Dim cmax As Long
'cmax = ws1.UsedRange.Rows.Count
k = 1
Set rng = ws1.Range("A1", ws1.Cells(1, Columns.Count).End(xlToLeft))
'Debug.Print rng.Address
For Each keyword In Array("Title", "Author", "Publication Title", "Volume", "Issue", "Pagination", "Abstract", "Document URL")
i = Application.Match(keyword, rng, 0)
If IsNumeric(i) Then
ws1.Columns(i).Copy ws2.Columns(k)
k = k + 1
End If
Next
End Sub
なんとなくこういうのなのかなあ、と想像しながら自分も書いてみました。
（きまぐれおじさん） 2021/12/01(水) 16:01
返信ありがとうございます。
さくさくアジフライさん、
説明まで加えていただき、ありがとうございます。
大変助かりました。
無事にNew Sheetにデータが抽出されたのですが、指定した"Title", "Author", "Publication Title", "Volume", "Issue", "Pagination", "Abstract", "Document URL"の他にも８列指定以外のタイトルデータが抽出されてしまいました。
きまぐれおじさん さん、
返信いただき、ありがとうございます。
End Subの６行上、i = Application.Match(keyword, rng, 0) でマクロが止まってしまいました。
すみません。今日は時間が取れないので、明日自分で調べてみます。
ひとまず、お礼とご報告でした。
（いちまつ） 2021/12/01(水) 17:54
上記が原因なら以下の部分を書き換えてみてください。
'rngの範囲内にj番目の列タイトルがあるか
If Not rng.Find(keywords(j)) Is Nothing Then
↓
'ws1の1行目i列の値とキーワードが一致か
If ws1.Cells(1,i).value=keywords(j)) Then
「Cells(1,i)」は「1行目i列のセル」を表していますので、
「1」の部分をタイトル行の行数に変更してください。
上記に変更した際は、以下の部分も不要となります。
'ws1のi番目列の1行目〜最終行の範囲をrngにセット
Set rng = ws1.Range("A1:A" & cmax).Offset(0, i - 1)
これで解決しなければ、
まずはステップ実行して
思い通りに動いていない部分が何処かを
確認していただくのが良いかと思います。
あとは最終行・最終列の指定方法について、
UsedRangeプロパティを使う方法とEndプロパティを使う方法があり、
それぞれ長所と短所があります。
（きまぐれおじさんさんのコードではEndプロパティで
最終列を取得しています）
下記をご一読いただき、データに合ったものを使ってみてください。
https://www.limecode.jp/entry/syntax/getlastrow
（さくさくアジフライ） 2021/12/01(水) 22:42
i = Application.Match(keyword, rng, 0)
ここで止まってしまう、とのことですが
もしかして変数iをLong型のままにしていませんか？
（Variant型にしてください。Application.Matchの出力が数値または文字列（エラーの場合）なので
Long型変数に文字列を代入できずエラーになっていることが想定されます）
keywordとrngはどんな値でもコードを止めてしまうようなエラーにはならないはずです。
（きまぐれおじさん） 2021/12/02(木) 00:35
ありがとうございます。
ご指摘いただいた箇所を修正し、どちらも無事にデータ抽出出来ました。
ご親切に説明いただき、感謝致します！！
今後とも、どうぞよろしくお願い致します。
（いちまつ） 2021/12/02(木) 10:28
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.