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

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

ただいまの
回答率

87.77%

複数ファイルのシートから集計用ファイルに転記したいです

受付中

回答 1

投稿 編集

  • 評価
  • クリップ 2
  • VIEW 4,309

score 10

前提・実現したいこと

条件
・集計用ファイル(以後、転記先)が存在する
・集計される複数のファイル(以後、転記元)は、特定のフォルダにまとめて格納されている
・転記元と転記先のファイル名は同一※ただし「yyyymm」のため月で変わる
・転記先にはマクロ起動前に、集計用シート作成済
・転記する列範囲は固定(A~I、M,N列)だが、行範囲が各ファイルによって変化する
・ものによっては該当シートがない場合もあるのでその時は無視して次のファイルの転記に移る

上記の条件でマクロを組みたいのですが
条件の下2つのコードに迷っています。

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

以下のコードの場合、該当するシートがないファイルでマクロが止まってしまう。

シートに記載されている分の転記ができない。

該当のソースコード

Sub tenki()
Dim folder As String    '//フォルダ
Dim file As String      '//ファイル選択
Dim book As Workbook    '//ブックオープン
Dim ws As Worksheet, flag As Boolean    '//参照シート有無
Dim i As Integer
i = 2

With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
folder = .SelectedItems(1)
End If
End With
'//フォルダを選択
file = Dir(folder & "\*.xlsx")

Do While file <> ""
'//ファイルを開く
Set book = Workbooks.Open(folder & "\" & file)

'//集計したい月のシートがあるか確認
For Each ws In Worksheets
If ws.Name = Format(Now, "yyyymm") Then flag = True
Next ws
If flag = True Then
ThisWorkbook.Worksheets(Format(Now, "yyyymm")).Range("A" & CStr(i)).Value = book.Worksheets(Format(Now, "yyyymm")).Range("A").Value
ThisWorkbook.Worksheets(Format(Now, "yyyymm")).Range("B" & CStr(i)).Value = book.Worksheets(Format(Now, "yyyymm")).Range("B").Value
ThisWorkbook.Worksheets(Format(Now, "yyyymm")).Range("C" & CStr(i)).Value = book.Worksheets(Format(Now, "yyyymm")).Range("C").Value
ThisWorkbook.Worksheets(Format(Now, "yyyymm")).Range("D" & CStr(i)).Value = book.Worksheets(Format(Now, "yyyymm")).Range("D").Value
ThisWorkbook.Worksheets(Format(Now, "yyyymm")).Range("E" & CStr(i)).Value = book.Worksheets(Format(Now, "yyyymm")).Range("E").Value
ThisWorkbook.Worksheets(Format(Now, "yyyymm")).Range("F" & CStr(i)).Value = book.Worksheets(Format(Now, "yyyymm")).Range("F").Value
ThisWorkbook.Worksheets(Format(Now, "yyyymm")).Range("G" & CStr(i)).Value = book.Worksheets(Format(Now, "yyyymm")).Range("G").Value
ThisWorkbook.Worksheets(Format(Now, "yyyymm")).Range("H" & CStr(i)).Value = book.Worksheets(Format(Now, "yyyymm")).Range("H").Value
ThisWorkbook.Worksheets(Format(Now, "yyyymm")).Range("I" & CStr(i)).Value = book.Worksheets(Format(Now, "yyyymm")).Range("I").Value
ThisWorkbook.Worksheets(Format(Now, "yyyymm")).Range("M" & CStr(i)).Value = book.Worksheets(Format(Now, "yyyymm")).Range("M").Value
ThisWorkbook.Worksheets(Format(Now, "yyyymm")).Range("N" & CStr(i)).Value = book.Worksheets(Format(Now, "yyyymm")).Range("N").Value

file = Dir()
i = i + 1

book.Close

Else
book.Close

End If

Loop

End Sub

試したこと

上記のコードをベースにしております。
いじる箇所は大体見当がつくのですがどうすればよいのか分からず……

補足情報(FW/ツールのバージョンなど)

ここにより詳細な情報を記載してください。

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

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

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

    クリップを取り消します

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

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

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

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

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

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

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

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

    質問の評価を下げる

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

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

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

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

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

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

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

    詳細な説明はこちら

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

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

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

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

  • azuapricot

    2019/02/05 17:19

    コードはマークダウンボタン (<code>ってやつです)を押したらでてくる
    ```ここに言語を入力
    コード
    ```
    ↑の枠の中のコードという文言を消して貼りつけてください。
    「ここに言語を入力」という文字を消してVBAと記述してください

    キャンセル

回答 1

+1

とりあえず明らかな間違いは、

For Each ws In Worksheets
    If ws.Name = Format(Now, "yyyymm") Then flag = True
Next ws

で一回 flag = True にしたらずっとTrueのままであるので、
これ以降のループで該当するシートがなくても転記処理が実行されてしまい、エラーになります。
flag = False で戻してからループに入りましょう。

ステップ実行すればすぐ見つかる間違いでしょう。
Excel VBA:ステップ実行でプログラムの動きをチェックする|Plus 1 Excel

また、該当シートが見つかったら最後までループする必要はないので、
Exit For でループを抜けましょう。

flag = False
For Each ws In book.Worksheets
    If ws.Name = Format(Now, "yyyymm") Then
        flag = True
        Exit For
    End If
Next ws

他にもコードに冗長な部分が見られますが、とりあえず上記の修正でたぶん動くでしょう(?)
Range("A").Value でエラーになりますね。Range("A" & CStr(i)).Value の間違いかな?
ただ、これだと1行だけしか転記されないが、それでいいのかな?


kiro_1002 さんのコメント

各ファイルによって入力されている量が異なるため、行範囲がバラバラなのでそれに適応できるととても助かります。

下記の方法で最終行が取得できるので、それをもとに範囲指定すればいいでしょう。

最終行の取得(End,Rows.Count)|VBA入門

投稿

編集

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

  • 2019/02/05 22:25

    ありがとうございます。

    転記は転記元に入力されている分の転記を行いたいです。条件に記載のある通り各ファイルによって入力されている量が異なるため、行範囲がバラバラなのでそれに適応できるととても助かります。


    イメージとしては
    ファイル1は各列10行まで入力されており、ファイル2は各列30行まで入力されている。

    それぞれ転記先へ

    となります。

    キャンセル

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

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

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