[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数ファイルのデータ(特定)を別ファイルへ抽出したい』(みん)
お世話になります。タイトルの通り、複数ファイルのデータを別ファイルへ抽出したいのですが、恥ずかしながらマクロは名前を聞いたことある程度で立ち上げることがやっとです。(過去ログも参考にしましたが、失敗。)
コードについて、お手数ですがご教示頂けませんでしょうか。
今後はコードをコピーするだけではなく、勉強したいと思います。
前置きが長くなりましたが、参照、抽出したいファイルは100個ほどあり、
タイトルはバラバラですが、抽出したいセルは全て同じです。
抽出したいセルは、
D10 (会社名がかかれています)
D11 (整理番号がかかれています)
行D15〜O15はそれぞれの列に複数の値が含まれています。
D15 A社
D16 B社
D17 C社
E15 100万
E16 10万
E17 1万
・
・
といった感じです。
よろしくお願いいたします。
< 使用 Excel:Excel2016、使用 OS:Windows10 >
>参照、抽出したいファイルは100個ほどあり
どこにあるのでしょうか。ファイルパス(とファイル名)がわからないと開けません。
>タイトルはバラバラですが
「タイトル」とは何でしょうか?(ファイル名?)
>抽出したいセルは全て同じ
シート名は? ファイルにはシートが1つだけなら問題ないですが。
>抽出したいセルは、
抽出してどうするのでしょうか? そもそも「抽出」とはどんな操作でしょうか?
(わからん) 2021/09/15(水) 15:00
>参照、抽出したいファイルは100個ほどあり
どこにあるのでしょうか。ファイルパス(とファイル名)がわからないと開けません。
⇒デスクトップにフォルダを作成し、その中に100個程のファイルを格納予定です。
>タイトルはバラバラですが
「タイトル」とは何でしょうか?(ファイル名?)
⇒ご指摘の通り、ファイル名です。
>抽出したいセルは全て同じ
シート名は? ファイルにはシートが1つだけなら問題ないですが。
⇒「名簿様式」と「入力例」の2種類が存在しています。(入力例のシートは抽出不要です)
>抽出したいセルは、
抽出してどうするのでしょうか? そもそも「抽出」とはどんな操作でしょうか?
⇒一覧で確認できるよう纏めたいだけです。
(みん) 2021/09/15(水) 15:16
デスクトップにフォルダを作り、抽出対象のファイルをいくつか入れて試してください。
↓の部分のフォルダ名を設定しておく必要があります。
「fpath = "C:\Users\xxxx\Desktop\フォルダ\" 'フォルダ名を指定(最後は「\」)」
シートにファイルの一覧が出てくればOKです。
Sub 抽出() Dim i As Long Dim fpath As String, f As String
fpath = "C:\Users\xxxx\Desktop\フォルダ\" 'フォルダ名を指定(最後は「\」)
i = 1 f = Dir(fpath & "*.xls?") Do While f <> "" Cells(i, "A") = f i = i + 1 f = Dir Loop
End Sub
(わからん) 2021/09/15(水) 17:23
(ほかの方の回答を邪魔する意図はありません)
(わからん) 2021/09/15(水) 19:17
Workbooks.Open fpath & f ' , ReadOnly:=True, UpdateLinks:=False ↓ Workbooks.Open fpath & f, ReadOnly:=True, UpdateLinks:=False また、ファイルを閉じるときに「保存しますか?」のようなメッセージがでる場合は、 下記の様に変える必要があります。 Workbooks(f).Close ' SaveChanges:=False ↓ Workbooks(f).Close SaveChanges:=False 試してみてください。
Sub 抽出() Dim i As Long Dim fpath As String, f As String
fpath = "C:\Users\xxxx\Desktop\フォルダ\" 'フォルダ名を指定(最後は「\」)
i = 1 f = Dir(fpath & "*.xls?") Do While f <> "" Cells(i, "A") = f '各ファイル処理 Workbooks.Open fpath & f ' , ReadOnly:=True, UpdateLinks:=False
'ここで転記処理
Workbooks(f).Close ' SaveChanges:=False '各ファイル処理 ここまで i = i + 1 f = Dir Loop
End Sub
(わからん) 2021/09/16(木) 08:21
上記ご記載頂いたコードで実行し、昨日同様ファイル名は転記され、
ファイルが開かれる動作が行われたことを確認いたしました。
一番初めに抽出したいセル番号を申し上げましたが、すみません抽出したいセルが変更、増えました。
P4… 部課名
P5… 担当者名
P6… メールアドレス
E15…下請事業者
F15…個人事業主
(このほかにも項目はありますが一旦ここまでの記載とさせて頂きます。)
尚、シート名は変更ありません。
マクロを実行し、一覧表示される際のレイアウトですが、
B2… 部課名
C2… 担当者名
D2… メールアドレス
E2… 下請事業者
F2… 個人事業主
とタイトルをつけて、部課名ならB3、B4、B5・・・・、メールアドレスならC3、C4、C5に
ズラッと抽出結果がでる仕組みにしたいと考えています。
よろしくお願いいたします。
(みん) 2021/09/16(木) 11:25
Sub 抽出() Dim i As Long Dim fpath As String, f As String Dim ws As Worksheet
fpath = "C:\Users\xxxx\Desktop\フォルダ\" 'フォルダ名を指定(最後は「\」)
Set ws = ActiveSheet ws.Range("B2") = "部課名" ws.Range("C2") = "担当者名" '** 他の項目も同様に追加 **
i = 3 f = Dir(fpath & "*.xls?") Do While f <> "" Cells(i, "A") = f 'ファイル名をA列に表示 ・・ 不要なら削除 '各ファイル処理 Workbooks.Open fpath & f ' , ReadOnly:=True, UpdateLinks:=False
'ここで転記処理 ws.Cells(i, "B") = Worksheets("名簿様式").Range("P4") '部課名 ws.Cells(i, "C") = Worksheets("名簿様式").Range("P5") '担当者名 '** 他の項目も同様に追加 **
Workbooks(f).Close ' SaveChanges:=False '各ファイル処理 ここまで i = i + 1 f = Dir Loop
End Sub
(わからん) 2021/09/16(木) 12:55
Sub 抽出()
Dim i As Long Dim fpath As String, f As String Dim ws As Worksheet fpath = "D:デスクトップXXXXX\" 'フォルダ名を指定(最後は「\」) Set ws = ActiveSheet ws.Range("B2") = "部課名" ws.Range("C2") = "担当者名" ws.Range("D2") = "メールアドレス" ws.Range("E2") = "下請事業者名" ws.Range("F2") = "個人事業主" ws.Range("G2") = "XXXXXXXX" ws.Range("H2") = "XXXXXXXX" ws.Range("I2") = "XXXXXXXX" ws.Range("J2") = "XXXXXXXX" ws.Range("K2") = "XXXXXXXX" ws.Range("L2") = "XXXXXXXX" ws.Range("M2") = "XXXXXXXX"
i = 3 f = Dir(fpath & "*.xls?") Do While f <> "" Cells(i, "A") = f 'ファイル名をA列に表示 ・・ 不要なら削除 '各ファイル処理 Workbooks.Open fpath & f ' , ReadOnly:=True, UpdateLinks:=False 'ここで転記処理 ws.Cells(i, "B") = Worksheets("名簿様式").Range("P4") '部課名 ws.Cells(i, "C") = Worksheets("名簿様式").Range("P5") '担当者名 ws.Cells(i, "D") = Worksheets("名簿様式").Range("P6") 'メールアドレス ws.Cells(i, "E") = Worksheets("名簿様式").Range("E15") '下請事業者名 ws.Cells(i, "F") = Worksheets("名簿様式").Range("F15") '個人事業主 ws.Cells(i, "G") = Worksheets("名簿様式").Range("G15") 'XXXXXXXX ws.Cells(i, "H") = Worksheets("名簿様式").Range("K15") 'XXXXXXXX ws.Cells(i, "I") = Worksheets("名簿様式").Range("L15") 'XXXXXXXX ws.Cells(i, "J") = Worksheets("名簿様式").Range("M15") 'XXXXXXXX ws.Cells(i, "K") = Worksheets("名簿様式").Range("N15") 'XXXXXXXX ws.Cells(i, "L") = Worksheets("名簿様式").Range("O15") 'XXXXXXXX ws.Cells(i, "M") = Worksheets("名簿様式").Range("P15") 'XXXXXXXX
Workbooks(f).Close ' SaveChanges:=False '各ファイル処理 ここまで i = i + 1 f = Dir Loop End Sub
A列に表示されるファイル名ですが、とても参考になりますので、削除せずそのままにしております。
ここまで、迅速にご対応頂きありがとうございます。何から何まで恐縮なのですが、
抽出する元のExcelについて、例えばE15の下請事業者名の解答が、E16、E17と続く場合、E16、E17の結果も反映させたいのですが、
どのように変更を加えればよろしいのでしょうか。(loop?ってやつでしょうか…)
実際のところ、下記の範囲は、何列も回答が続くと予想されます。
ws.Cells(i, "E") = Worksheets("名簿様式").Range("E15") '下請事業者名 ws.Cells(i, "F") = Worksheets("名簿様式").Range("F15") '個人事業主 ws.Cells(i, "G") = Worksheets("名簿様式").Range("G15") 'XXXXXXXX ws.Cells(i, "H") = Worksheets("名簿様式").Range("K15") 'XXXXXXXX ws.Cells(i, "I") = Worksheets("名簿様式").Range("L15") 'XXXXXXXX ws.Cells(i, "J") = Worksheets("名簿様式").Range("M15") 'XXXXXXXX ws.Cells(i, "K") = Worksheets("名簿様式").Range("N15") 'XXXXXXXX ws.Cells(i, "L") = Worksheets("名簿様式").Range("O15") 'XXXXXXXX ws.Cells(i, "M") = Worksheets("名簿様式").Range("P15") 'XXXXXXXX
お手数ですがどうぞよろしくお願いいたします。
(みん) 2021/09/16(木) 15:04
さて、複数回答への対応をしてみました。
どの行まで回答があるかの判定が手抜きですので、ご希望と違う結果になるかもしれません。
お試し下さい。
Sub 抽出() Dim i As Long, j As Long Dim fpath As String, f As String Dim ws As Worksheet
fpath = "D:デスクトップXXXXX\" 'フォルダ名を指定(最後は「\」)
Set ws = ActiveSheet ws.Cells.ClearContents 'クリア 消したくないセルがあれば、「ws.Range("A2:L50").ClearContents」みたいに範囲限定する ws.Range("B2") = "部課名" ws.Range("C2") = "担当者名" ws.Range("D2") = "メールアドレス" ws.Range("E2") = "下請事業者名" ws.Range("F2") = "個人事業主" ws.Range("G2") = "XXXXXXXX" ws.Range("H2") = "XXXXXXXX" ws.Range("I2") = "XXXXXXXX" ws.Range("J2") = "XXXXXXXX" ws.Range("K2") = "XXXXXXXX" ws.Range("L2") = "XXXXXXXX" ws.Range("M2") = "XXXXXXXX"
i = 3 f = Dir(fpath & "*.xls?") Do While f <> "" Cells(i, "A") = f 'ファイル名をA列に表示 ・・ 不要なら削除 '各ファイル処理 Workbooks.Open fpath & f ' , ReadOnly:=True, UpdateLinks:=False
With Worksheets("名簿様式") '記述を省略できるようにする .Range("P4") はWorksheets("名簿様式").Range("P4") の意味になる 'ここで転記処理 ws.Cells(i, "B") = .Range("P4") '部課名 ws.Cells(i, "C") = .Range("P5") '担当者名 ws.Cells(i, "D") = .Range("P6") 'メールアドレス
'複数行に対応 j = 15 Do While WorksheetFunction.CountA(.Range(.Cells(j, "E"), .Cells(j, "M"))) > 0 'E列〜P列に記載がある間ループする '転記しないH〜J列に記載があると不要な行がでてくる。要検討。 ws.Cells(i, "E") = .Range("E" & j) '下請事業者名 ws.Cells(i, "F") = .Range("F" & j) '個人事業主 ws.Cells(i, "G") = .Range("G" & j) 'XXXXXXXX ws.Cells(i, "H") = .Range("K" & j) 'XXXXXXXX ws.Cells(i, "I") = .Range("L" & j) 'XXXXXXXX ws.Cells(i, "J") = .Range("M" & j) 'XXXXXXXX ws.Cells(i, "K") = .Range("N" & j) 'XXXXXXXX ws.Cells(i, "L") = .Range("O" & j) 'XXXXXXXX ws.Cells(i, "M") = .Range("P" & j) 'XXXXXXXX i = i + 1 j = j + 1 Loop End With
Workbooks(f).Close ' SaveChanges:=False '各ファイル処理 ここまで
f = Dir '次のファイル Loop
End Sub
(わからん) 2021/09/16(木) 16:47
下記、H〜J列は、記載できないよう注記を入れているので、問題ないかと存じます。
ご配慮頂き感謝です。
一点、下記A3よりファイル名が表示されますので、A2に「ファイル名」と記載しレイアウトを変更しました。
しかしながら、マクロを実行すると、A2の「ファイル名」の文字が消えてしまいます。
「ClearContents」というものがセルを削除するもの?だと調べてみまして、おそらく、
--qte-- ws.Cells.ClearContents 'クリア 消したくないセルがあれば、ws.Range("A2:L50").ClearContents」みたいに範囲限定する
こちらを修正する必要があると考え、ご教示の通り("A2:M200")(←※(L50)から範囲を広げました。)に
変更してしましたがA2の「ファイル名」文字が消えてしまいます。
ご解決方法につき、何度も恐縮ですがご教示頂ければ幸いです。よろしくお願いいたします。
(みん) 2021/09/16(木) 17:42
さて、A2セルが消えてしまう件ですが、
("A2:M200")だとA2は消えるので("A3:M200")とするか、
ws.Range("B2") = "部課名" と同じようにA2へ「ファイル名」を書き込むといいでしょう。
(わからん) 2021/09/16(木) 18:09
二日間にわたり、多大なるご助力を誠にありがとうございました。
これで満足せず、明日からコードを1行1行調べて、自分で組めるよう努めたいと思います。
本当にありがとうございました。
(みん) 2021/09/16(木) 18:25
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.