質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

90.52%

  • VBA

    1797questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

複数ブック、複数シートからの値コピー

受付中

回答 2

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 2,205

m73

score 2

 前提・実現したいこと

[実現したいこと]
VBAにて集計表を作成しております。
勉強をし始め、数日です。
複数ブックの複数シートから値のみコピーしたいと思っています。

[前提]
・集計元は1つのフォルダにまとまっている
・集計元は複数のブックにわかれている
またBookの名前もまちまちである。
Book1.xlsx、ABC.xlsx、111.xlsx・・・
・集計元の1つのブックには複数のシートが含まれている
シートの枚数、名前はブックによってまちまち
・各シートはブックが分かれていても全て共通のフォーマット

①集計元のブック(元データが記載されている)の各シートのA2のセルをコピー → 集計先のB列に貼り付け
②集計元のブック(元データが記載されている)のD2のセルをコピー → 集計先のC列に貼り付け
③集計元のブック、シート名をA列にはりつけ

ということをおこないたいです。
やりたいことと乖離してしまっているためご教示を頂きたいです。

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

まず前提の①が行えるか試した所、以下を実行すると
1つ目のブックの各シートをコピーしましたが
2つ目のブックを開いたあと、1つ目の下データのブックの値に上書きされてしまいました。

また②の、集計元のブック(元データが記載されている)のD2のセルをコピー → 集計先のB列に貼り付けに関しても変数が複数になると理解がおいついておりません。

言い訳にするつもりではないのですが、
勉強が浅いため、作成したコードもお見苦しい点ばかりかと思います。
何卒お力お借りしたく思います。

 該当のソースコード

Sub TEST()
Dim myPath As String
Dim myFile As String
Dim i As Long

myPath = ThisWorkbook.Path
myFile = Dir(myPath & "\" & "*.xlsx") 

Do Until myFile = ""

Workbooks.Open myPath & "\" & myFile 
Sheets("Sheet1").Select
For i = 1 To Worksheets.Count

Worksheets(i).Range("A2").Copy

ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).PasteSpecial _
xlPasteValuesAndNumberFormats

Next i

myFile = Dir()

Loop
End Sub
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • coco_bauer

    2018/05/11 16:24

    複数のシートを持つ複数のブックから、A2セルとD2セルの内容を収集するだけで良いのですか? 情報源となったブックの名前とワークシートの名前ぐらいは残さないと、後で困るのではないかと危惧します。

    キャンセル

  • m73

    2018/05/11 16:29

    >coco_bauer様  仰られるとおりです、ご指摘切に感謝いたします。質問を一部編集させて頂きます。

    キャンセル

  • mts10806

    2018/05/11 16:41

    プログラムコード(およびエラーメッセージ)は```で囲ってください。(わからなければ質問編集画面でコード部分を選択し<code>ボタンを押してください)正しく反映されているかどうかは質問編集画面のプレビューを見ながら編集していってください。

    キャンセル

  • m73

    2018/05/11 16:49

    >mts10806様 失礼いたしました。ご指摘感謝いたします。早々に修正いたします。

    キャンセル

回答 2

0

変数が複数になると理解がおいついておりません。

変数は使いたい値に対するメモのようなものです。
メモの名前が適当だと何を表しているのかわかりにくいため、自分がわかりやすい名前を付けてあげると上手くようになると思います。

 VBAのデバッグ時に便利な機能

 ローカルウィンドウ

ローカル変数(プロシージャの中で作った変数)の中身を簡単に確認できるウィンドウです。
ステップ実行や、ブレークポイントと組み合わせると、今どんな状態なのか、を簡単に確認できます。

 イミディエイトウィンドウ

ローカルウィンドウで変数の中はある程度は見えますが、一部確認できないものもあります。
そのような場合は、イミディエイトウィンドウを使用すると、その場で簡単なコードを実行して結果を確認できます。

'イミディエイトウィンドウ内:値の確認
?Range("A1").Value '~Valueまで入力してEnter→A1セルの値が表示される
'イミディエイトウィンドウ内:何か実行
Range("A1").Select '~Selectまで入力してEnter→A1セルが選択される

①集計元のブック(元データが記載されている)の各シートのA2のセルをコピー → 集計先のB列に貼り付け

の部分だけサンプルを作ってみました。

若干変数過多の気はありますが参考になれば。

Sub TEST2()

    'コピー先のシート
    Dim copyToSheet As Worksheet
    Set copyToSheet = ThisWorkbook.Worksheets("Sheet1")

    '集計元A2セルのコピー先(開始位置)
        '適当な名前なので、値の意味を踏まえた名前にした方が良い
    Dim A2CopyToCell As Range
    Set A2CopyToCell = copyToSheet.Range("B1")

    'xlsxファイルを検索するフォルダ(末尾\付き)
        'ThisWorkbook.Path & "\" はなんども出てくるので先にまとめてしまう
    Dim searchFolderPath As String
    searchFolderPath = ThisWorkbook.Path & "\"

    '見つかったxlsxファイルの名前
    Dim findXlsxName As String
    findXlsxName = Dir(searchFolderPath & "*.xlsx")

    Do Until findXlsxName = ""

        'コピー元のブックを開く
        Dim copyFromBook As Workbook
        Set copyFromBook = Workbooks.Open(searchFolderPath & findXlsxName)

        'For Each は「何かの集まり全て」(今回は`copyFromBook`のワークシート全て)に対して処理をする
        Dim ws As Worksheet
        For Each ws In copyFromBook.Worksheets
            '`ws`には 元のコードでの`Worksheets(i)`に相当するものが自動で入ります

            '①集計元のブック(元データが記載されている)の各シートのA2のセルをコピー → 集計先のB列に貼り付け
            Dim A2CopyFromCell As Range
            Set A2CopyFromCell = ws.Range("A2")

            'コピー先のセルの値にコピー元のセルの値を入れる
            A2CopyToCell.Value = A2CopyFromCell.Value


            '次のコピー先のセルは、今のコピー先のセルから1行0列動いたセル(→1つ下のセル)
            Set A2CopyToCell = A2CopyToCell.Offset(1, 0)

            '②集計元のブック(元データが記載されている)のD2のセルをコピー → 集計先のC列に貼り付け
            'TODO

            '③集計元のブック、シート名をA列にはりつけ
            'TODO
                '集計元のブックの名前→copyFromBook.Name
                'シート名→ws.Name


        Next ws

        findXlsxName = Dir()

    Loop

End Sub

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

0

まずは、確認。
集計元と集計先のブックは同じフォルダーにあるのですか。
(コードを見る限りは同じフォルダーですね。)
また、このマクロは集計先のファイルにあるのですね。

上記があっているとして、

DoループでDir関数を使ってファイル名を順次取得する部分と、Forループで各シートを順次取得して処理していく部分はいいですが、Forのループ変数(i)を行インデックスしているのが間違いですね。
別ブックへ移行するときに、1 に戻ってしまいますので、同じところを上書きすることになります。

入力行用の変数を別に用意して、カウントアップするようにする必用があります。

現状のコードをなるべく活かして、上記の点と、A列にブック名!シート名の入力も追加したコード例をとりあえず提示します。

Sub 取り込みテスト()
    Dim myPath As String
    Dim myFile As String
    Dim MyBook As Workbook
    Dim CurRow As Long '入力する行インデックス
    Dim i As Long

    myPath = ThisWorkbook.Path
    myFile = Dir(myPath & "\" & "*.xlsx")
    CurRow = 1
    Do Until myFile = ""
        Workbooks.Open myPath & "\" & myFile
'       Sheets("Sheet1").Select ←不必要だし、「Sheet1」という名前のシートがなければエラーになる
        For i = 1 To Worksheets.Count
            Worksheets(i).Range("A2").Copy
            ThisWorkbook.Worksheets("Sheet1").Cells(CurRow, 2).PasteSpecial _
                    xlPasteValuesAndNumberFormats
            Worksheets(i).Range("D2").Copy
            ThisWorkbook.Worksheets("Sheet1").Cells(CurRow, 3).PasteSpecial _
                    xlPasteValuesAndNumberFormats
            ThisWorkbook.Worksheets("Sheet1").Cells(CurRow, 1).Value = myFile & "!" & Worksheets(i).Name
            CurRow = CurRow + 1 '入力行をカウントアップ
        Next i

        myFile = Dir()
    Loop

End Sub

これで希望の動作にはなると思います。
ただ、アクティブブック、シートが移動するのでチラツキますし、
クリップボード経由なので処理も重いです。
また、ブックが開きっぱなしなのも気になりますね。

この辺りは完全の余地が大です。
ヒントを出しておきますと、
Application.ScreenUpdating を使って画面更新を抑止するとチラツキを抑制できます。
Copy PasteSpecial を使わなくても、代入という処理で値を入力できます。

追記

タッチの差で、imihitoさんに先を越されました。しかも、より完成度の高いコードです。
まずは、私のコードは、元のコードとほぼと同じなので意味はすぐ理解できると思います。
それを理解した上で、imihitoさんのコードを、私との違いを意識しながら、読むと理解が捗ると思います。

上記のコードの改良版

Sub 取り込みテスト()
    Dim myPath As String
    Dim myFile As String
    Dim FromBook As Workbook '集計元ブック
    Dim ToSheet As Worksheet '集計先シート
    Dim CurRow As Long '入力する行インデックス
    Dim i As Long

    Set ToSheet = ThisWorkbook.Worksheets("Sheet1") '
    myPath = ThisWorkbook.Path & "\"
    myFile = Dir(myPath & "*.xlsx")

    Application.ScreenUpdating = False '画面更新の抑制

    CurRow = 1
    Do Until myFile = ""
        Set FromBook = Workbooks.Open(myPath & "\" & myFile) '開いたブックを変数にセット
        For i = 1 To FromBook.Worksheets.Count
            With FromBook.Worksheets(i)
                ToSheet.Cells(CurRow, 1).Value = myFile & "!" & .Name
                ToSheet.Cells(CurRow, 2).Value = .Range("A2").Value
                ToSheet.Cells(CurRow, 3).Value = .Range("D2").Value
            End With
            CurRow = CurRow + 1 '次の行に移動
        Next i
        FromBook.Close '集計元ブックを閉じる
        myFile = Dir()
    Loop
    Application.ScreenUpdating = True

    MsgBox "取り込み完了しました。"
End Sub

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 90.52%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

  • 受付中

    ExcelVBAで複数のブックからデータを別ブックのシートに横に貼り付けるには

    前提・実現したいこと ここに質問したいことを詳細に書いてください ExcelVBAで基本統計量を計算するツールを作っています。 複数のブック(例:ブック名”2016/05”な

  • 解決済

    シートのコピー

    vbaにて開いたexcelのシートをマクロ等を実行しているexcelのSheet1にコピーしたいのですが、どのように記述したらよいでしょうか。 Sheet1が既に存在した場合Sh

  • 受付中

    【VBA】複数シートのデータを順番に計算して、結果を別ブックのシートに同じ順番に書き込む

    【VBA】複数シートのデータを順番に計算して、結果を別ブックのシートに元データのシートと同じ順番に書き込む VBAで回帰分析を行うなシステムを作っています。 現在、一つのシートをか

  • 受付中

    VBAで別のブックのシートに記録する

    前提・実現したいこと 複数の月ごとになっているシートにデータが2列同行数記録されています。その2列のデータを用いてある計算をして、別ブックの月ごとのシートに計算結果を次々に記録して

  • 解決済

    別ファイルのセル 操作

    別ファイルのセルの操作ができず、困っています。 ファイルAからファイルBを開き、ファイルBを閉じるときに、ファイルAに値を反映させて、ファイルBを閉じる処理を行いたいと思ってお

  • 解決済

    VBA高速化について

    20個のエクセルファイルを読み込み、特定のシートにあるテーブルから特定の値を探し出し、その右横にあるセルの値を取り出します。 集計用のエクセルのテーブルでも、同じ特定の値をテーブル

  • 解決済

    フォルダ内の全てのExcelに同じ処理を繰り返す (VBA)

    【実施したいこと】 フォルダ内にExcelファイルが約200個あります。 この全てのに同じ処理をしたいのですが、マクロで繰り返す方法がわからないので教えて下さい。 処理をする内容は

  • 解決済

    【VBA】最終行に転記

     前提・実現したいこと (同一book) 【入力】シートに入力したものを【点検履歴】シートの最終行に転記したいです。 ↓入力シート(sheet9) ↓点検履歴(sheet8)

同じタグがついた質問を見る

  • VBA

    1797questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。