[[20210915142537]] 『複数ファイルのデータ(特定)を別ファイルへ抽出し』(みん) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『複数ファイルのデータ(特定)を別ファイルへ抽出したい』(みん)

お世話になります。タイトルの通り、複数ファイルのデータを別ファイルへ抽出したいのですが、恥ずかしながらマクロは名前を聞いたことある程度で立ち上げることがやっとです。(過去ログも参考にしましたが、失敗。)
コードについて、お手数ですがご教示頂けませんでしょうか。
今後はコードをコピーするだけではなく、勉強したいと思います。

前置きが長くなりましたが、参照、抽出したいファイルは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


ありがとうございます。
デスクトップにファイルを作成し、pathを指定箇所にいれて、ファイル名は表示されたこと確認いたしました。
(みん) 2021/09/15(水) 17:39

続きは明日になります。
 ファイルのオープン
 シート「名簿様式」の存在チェック
 各ファイルのD10セルの取得
ここまでできれば、ほぼ完成です。
一覧表示にしたときのレイアウトを考えておいてください。

(ほかの方の回答を邪魔する意図はありません)

(わからん) 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


お忙しいところ早速にありがとうございました。
実行してみると「インデックス有効範囲にありません」と表示され、
「ws.Cells(i, "B") = Worksheets("名簿様式").Range("P4") '部課名」が黄色ハイライトされました。
エラーの意味を調べてみたところ、シート名「名簿様式」に空白が入っていたようで認識されていなかったみたいです。こちらは無事に解消されました。
項目については、マネさせて頂き下記のように追加しました。(名前は伏せさせて頂きます)

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


理解しておらず失礼しましたm(__)m
"A3:M200"で無事に解決できました。

二日間にわたり、多大なるご助力を誠にありがとうございました。
これで満足せず、明日からコードを1行1行調べて、自分で組めるよう努めたいと思います。

本当にありがとうございました。
(みん) 2021/09/16(木) 18:25


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.