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

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

新規登録して質問してみよう
ただいま回答率
86.02%
VBA

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

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

ループ

ループとは、プログラミングにおいて、条件に合致している間、複数回繰り返し実行される箇所や、その制御構造を指します

Q&A

解決済

VBAに関する質問(特定フォルダのすべてのファイルに実行する処理でループ処理が働かない)

kkkrw
kkkrw

総合スコア1

VBA

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

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

ループ

ループとは、プログラミングにおいて、条件に合致している間、複数回繰り返し実行される箇所や、その制御構造を指します

1回答

0グッド

0クリップ

268閲覧

投稿2022/11/05 00:22

編集2022/11/05 00:52

マクロで特定のフォルダにあるすべてファイルのセル”A2:B2”をコピーして、
指定したファイルに自動転記したいです。

下記コードを作成して、実行してみたところ、動作はしますが
すべてのファイルを実行するようなループ処理が働きません。
テストした際は、特定フォルダに3つのファイルを格納しましたが、
1つのファイルのみの”A2:B2”がコピペされているようでした。
当方初心者で原因がどうしてもわからないので、教えていただけると幸いです。

ーーーーーーー以下書いたコード

VBA
コード

Sub 一括取込() Dim folderPath As String Dim filePath As String With Application.FileDialog(msoFileDialogFolderPicker) .Title = "取込場所の選択" 'タイトルの指定 .InitialFileName = "" '初期表示フォルダの指定 If .Show = True Then 'ダイアログを表示して戻り値を判定 folderPath = .SelectedItems(1) 'フォルダのパスを取得 Else Exit Sub End If End With With Application.FileDialog(msoFileDialogFilePicker) .Title = "転記先の選択" 'タイトルの指定 .InitialFileName = "" '初期表示フォルダの指定 If .Show = True Then 'ダイアログを表示して戻り値を判定 filePath = .SelectedItems(1) 'ファイルのパスを取得 Else Exit Sub End If End With Dim myPath As String, myBook As String, last As Integer, i As Long Dim wb1 As Workbook, wb2 As Workbook Dim ws1 As Worksheet, ws2 As Worksheet myPath = folderPath myBook = Dir(myPath & "\*.xlsx") 'ワイルドカード(*)を使用し、xlsx拡張子のファイルをすべて Set wb1 = Workbooks.Open(filePath) Set ws1 = wb1.Sheets("Sheet1") Application.ScreenUpdating = False 'ちらつき防止 filePath = Dir(filePath) Workbooks.Open filePath Do While myBook <> "" Set wb2 = Workbooks.Open(myPath & "\" & myBook) Set ws2 = wb2.Sheets("Sheet1") ws2.Range("A2:E2").Copy last = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Offset(1).Row ws1.Range("A" & last).PasteSpecial Paste:=xlPasteValues ’コピーしたファイルを最終行の下にペースト Set ws2 = Nothing Set wb2 = Nothing myBook = Dir() Loop Application.ScreenUpdating = True 'ちらつき防止 wb1.Save Set ws1 = Nothing Set wb1 = Nothing End Sub

以下のような質問にはグッドを送りましょう

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

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

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

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

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

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

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

適切な質問に修正を依頼しましょう。

hatena19

2022/11/05 00:45

コードの一部しかマークダウンのコードブロックに入っていません。 コード全体を下記のようにコードブロック内に入れてください。 ```vba ここにコード全体 ```
kkkrw

2022/11/05 00:53

失礼いたしました。コードブロックを修正いたしました。

回答1

1

ベストアンサー

処理としては、下記の3つになります。

  • 取込元フォルダの選択
  • 転記先ブックを選択して開く
  • 取込元フォルダのxlsxファイルのループ処理

これらの処理をそれぞれ纏めて記述すると読みやすくなると思います。(好みはあると思いますが)
現状はこれらが混ざっているので混乱しているようです。

あと、Dir関数でフォルダ内ファイルをループするときは、下記のようなコードになります。

vba

1myBook = Dir(フォルダパス) 2Do While myBook <> "" 3 'ブックに対する処理 4 myBook = Dir() 5Loop

上記を考慮して、修正すると下記のようなコードになります。

vba

1Sub 一括取込() 2 '取込元フォルダの選択 3 Dim folderPath As String 4 With Application.FileDialog(msoFileDialogFolderPicker) 5 .Title = "取込場所の選択" 'タイトルの指定 6 .InitialFileName = "" '初期表示フォルダの指定 7 If .Show = True Then 'ダイアログを表示して戻り値を判定 8 folderPath = .SelectedItems(1) 'フォルダのパスを取得 9 Else 10 Exit Sub 11 End If 12 End With 13 14 '転記先ブックの選択 15 Dim filePath As String 16 With Application.FileDialog(msoFileDialogFilePicker) 17 .Title = "転記先の選択" 'タイトルの指定 18 .InitialFileName = "" '初期表示フォルダの指定 19 If .Show = True Then 'ダイアログを表示して戻り値を判定 20 filePath = .SelectedItems(1) 'ファイルのパスを取得 21 Else 22 Exit Sub 23 End If 24 End With 25 Dim wb1 As Workbook, ws1 As Worksheet 26 Set wb1 = Workbooks.Open(filePath) '転記先ブックを開く 27 Set ws1 = wb1.Sheets("Sheet6") 28 29' Application.ScreenUpdating = False 'ちらつき防止 30 31 '取込場所フォルダのxlsxファイルのループ処理 32 Dim myBook As String, lastCell As Range 33 Dim wb2 As Workbook, ws2 As Worksheet 34 myBook = Dir(folderPath & "\*.xlsx") 'xlsx拡張子の最初のファイル名を取得 35 Do While myBook <> "" 36 Set wb2 = Workbooks.Open(folderPath & "\" & myBook) 37 Set ws2 = wb2.Sheets("Sheet1") 38 39 ws2.Range("A2:E2").Copy 40 Set lastCell = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Offset(1) '最終行の下のセルを取得 41 lastCell.PasteSpecial Paste:=xlPasteValues 42 wb2.Close '開いたブックは閉じる 43 44 myBook = Dir() 'xlsx拡張子の次のファイル名を取得 45 Loop 46 Set wb2 = Nothing 47 48 Application.ScreenUpdating = True 'ちらつき防止 49 50 wb1.Save 51 Set ws1 = Nothing 52 Set wb1 = Nothing 53End Sub

投稿2022/11/05 01:42

hatena19

総合スコア32018

okakemetal👍を押しています

良いと思った回答にはグッドを送りましょう。
グッドが多くついた回答ほどページの上位に表示されるので、他の人が素晴らしい回答を見つけやすくなります。

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

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

このような回答には修正を依頼しましょう。

回答へのコメント

kkkrw

2022/11/05 04:09

ありがとうございます。無事に処理ができました。 ご説明も非常にわかりやすかったです。

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

ただいまの回答率
86.02%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問

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

VBA

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

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

ループ

ループとは、プログラミングにおいて、条件に合致している間、複数回繰り返し実行される箇所や、その制御構造を指します