[[20210215095139]]　『複数の別ブックからデータを転記するマクロを作り』（kaori）　ページの最後に飛ぶ

『複数の別ブックからデータを転記するマクロを作りたい』（kaori）

フォルダ内にある複数ブックにあるデータ(様式はどれも同じ)を最終行までコピーし、一つのシートに集約するマクロを作ってみたのですが、ブックを開くところまで動くのに転記が最後のデータだけになってしまい困っています
どこを修正すべきか教えていただけると嬉しいです
よろしくお願いします

Sub 一括取得()
　Dim folder As String
　Dim file As String
　Dim shtName As String
　Dim nowRow As Long
　Dim shtTaisyo As Worksheet
　Dim shtSyuyaku As Worksheet
　Dim startRow As Long
　Dim lastRow As Long
　Dim ext As String
　Dim wb As Workbook
　Dim fso As Object
　Dim f As Object
　
　With Application.FileDialog(msoFileDialogFolderPicker)
　If .Show = True Then
　folder = .SelectedItems(1)
　End If
　End With
　
　file = Dir(folder & “\*.xlsx”)

　shtName = “入力用”
　startRow = 4
　nowRow = 2
　Set shtSyuyaku = Thisworkbook.Sheets(shtName)
　Set fso = CreateObject(“Scripting.FileSystemObject”)
　For Each f In fso.GetFolder(folder).Files
　ext = LCase(fso.getextensionName(f.Name))
　Set wb = Workbooks.Open(folder & “\” & f.Name)
　Set shtTaisyo = wb.Sheets(shtName)
　lastRow = shtTaisyo.Cells(startRow, 1), shtTaisyo.Cells(lastRow, 15)).Copy (shtSyuyaku.Cells(nowRow, 1))
　nowRow = nowRow + lastRow - (startRow - 1)
　wb.Close
　Set wb = Nothing
　Next
　
　MsgBox “完了”
End Sub

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

 こんにちは　＾＾
コピーは-1を返していると思われます、結果
nowRowが変化していないのではないでしょうか。
nowRow 止めて、lastRowだけでいけば、すっきりするのでは。
最初のlastRowは2で別途lastRowを取得する。とかで行けるか
もしれません。。。←　多分　＾＾；。。。。m(__)m
（隠居じーさん） 2021/02/15(月) 11:07

ＶＢＡ最終行の取得。。。とかで検索すれば
どどっと、懇切丁寧な解説があるサイトが
ヒットしますです。m(__)mでわ
（隠居じーさん） 2021/02/15(月) 11:18

ｗ。。。って言う前に、コンパイルエラーでした。。。＾＾；
ま、こちらへの、アップ時のコピペミスだとは思いますが。。。
(#^.^#)　～　m(__)m。。。ちょこっと調べてみます
（隠居じーさん） 2021/02/15(月) 11:27

アドバイスいただきありがとうございます
コピペミスで最終行の取得部分が消えていましたので、修正版を投稿させてもらいます
よろしくお願いします

shtTaisyo.Range(shtTaisyo.Cells(startRow, 1), shtTaisyo.Cells(lastRow, 15)).Copy (shtSyuyaku.Cells(nowRow, 1))
　nowRow = nowRow + lastRow - (startRow - 1)
　wb.Close
　Set wb = Nothing
　Next
　
　MsgBox “完了”
End Sub
（kaori） 2021/02/15(月) 12:34

こんにちは　＾＾
こちらで拝見させて戴いた限りでは、正常動作の
ように、お見受け致しますが、何が問題なので。
行ずれまでは、検閲致しておりませんが。。。
。。。m(_ _)m
（隠居じーさん） 2021/02/15(月) 13:07

 あの～確かに、不必要なコードがあったり、後始末の
問題とかはあるかも。。。ですがこちらは賛否両論なので
私の勘違いも、あったかもですが動いていますですよ。。。
(#^^#)ｖ
（隠居じーさん） 2021/02/15(月) 13:11

返信ありがとうございます
フォルダ内にいくつかデータを入れて読み取らせているのですが、全てのデータを転記してくれず、順番に開いていって最後のデータdけが転記されてしまい困っています…(1つだけデータを入れた時は問題なく動くのですが、2つ以上入れると1つしか転記されなくなってしまいます)
マクロに問題がないとすればフォルダ内に入れたデータの問題でしょうか…？
（kaori） 2021/02/15(月) 13:28

 え。。。そぉなのですね。。。
あの、読込先のシート名は　全て　入力用　ですよね。
書込み先のシーと名も　入力用　で、合っていますでしょうか。
読込み開始行は、全て、4行目から、最終行まで、みたいですけど
その範囲に、何も情報が無い。。。とかは。。。ないですよね。
とりあえず、今、頭に、パッと浮かんだのはこれくらいでして
また、何か解りましたら、現れますが。。。
他の回答者様のアドバイスをお待ちくださいませ。。。m(_ _)m
（隠居じーさん） 2021/02/15(月) 15:01

失礼致しました、シート名が違ったり、他のファイルだと
エラーになると思いますので。エラーにならないというう事は。
読込成功したブックと、失敗するブックの入力用シートの
フォーマットは同じでしょうか。
Ａ列の最終行を拾っていますので、ここが空だと、何もしない
と思います。
（隠居じーさん） 2021/02/15(月) 15:13

 こんばんは　＾＾　これではどうなりますでしょう。。。(￣▽￣)
メッセージが出るか、又は、ダメでしたら、教えて下さいね。
Option Explicit
Sub 一括取得02()
    Dim folder As String
    Dim shtName As String
    Dim nowRow As Long
    Dim shtTaisyo As Worksheet
    Dim shtSyuyaku As Worksheet
    Dim startRow As Long
    Dim lastRow As Long
    Dim wb As Workbook
    Dim fso As Object
    Dim f As Object
    Dim fdg
    Set fdg = Application.FileDialog(msoFileDialogFolderPicker)
    If fdg.Show = False Then
        Set fdg = Nothing
        Exit Sub
    End If
    folder = fdg.SelectedItems(1)
    shtName = "入力用"
    startRow = 4
    nowRow = 2
    Set shtSyuyaku = ThisWorkbook.Sheets(shtName)
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each f In fso.GetFolder(folder).Files
        Set wb = Workbooks.Open(folder & "\" & f.Name)
        Set shtTaisyo = wb.Sheets(shtName)
        With shtTaisyo
            lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
            If lastRow < 5 Then MsgBox "要情報確認" & Chr(13) & wb.Name
            .Range(.Cells(startRow, 1), .Cells(lastRow, 15)).Copy shtSyuyaku.Cells(nowRow, 1)
        End With
        With shtSyuyaku
            nowRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        End With
        wb.Close
        Set shtTaisyo = Nothing
        Set wb = Nothing
    Next
    Set fdg = Nothing
    Set shtSyuyaku = Nothing
    Set fso = Nothing
    MsgBox "完了"
End Sub
（隠居じーさん） 2021/02/15(月) 15:50

横からですが。

■１
こだわりがなければ、インデントを付けた方がコードが見やすく（メンテナンスしやすく）なるとおもいますので、整理してみてはどうでしょうか。

■２
提示のコードだと、フォルダを選択してもらえなかった時でも次に進んでしまいますので「folder」が空っぽだったら、処理を中断するようにしたほうがよいとおもいます。

■３
一度しか使わないようなものもわざわざ変数に格納しています。
ダメとはいいませんが、複雑化して分かりづらくなる原因にもなるので、コード中にそのまま記述できないか検討したほうがよいとおもいます。

■４
↓はどのような意図で記述したのでしょうか？変数に格納するだけで使ってないですよ。

 ext = LCase(fso.getextensionName(f.Name))

参考にされたコードが何かわかりませんが、本来はExcelブックかどうか拡張子で判定していたのではありませんか？
※ピンと来ない場合は↓を読んでみてください。
http://officetanaka.net/excel/vba/filesystemobject/sample07.htm

■５
↓も参考にされたコードがわかりませんが、どちらか要らないですよ。（たぶん）

 file = Dir(folder & "\*.xlsx")

 For Each f In fso.GetFolder(folder).Files

ただ、前者を採用とするのであれば、ループ処理の部分が不足してますし、後者を採用とするなら「■４」のとおり、拡張子判定の部分が抜けてます。

■６
ちなみに、ネット検索で見つかったコードや、質問掲示板のコードを、ただ実行してみたり眺めていたりするだけだと、なかなか理解しづらいとおもいますので、【ステップ実行】という手法を使い１行ずつ実行していき、どのような動きをするのか確認したり、変数に何が格納されているのかチェックするようにすると、理解しやすいとおもいます。

ついては【ステップ実行】という言葉を聞いたことがなければ↓をよんでみてください。

 【ステップ実行】
https://www.239-programing.com/excel-vba/basic/basic023.html
http://plus1excel.web.fc2.com/learning/l301/t405.html

 ついでに↓も覚えてしまいましょう。

 【イミディエイトウィンドウ】
https://www.239-programing.com/excel-vba/basic/basic024.html
https://excel-ubara.com/excelvba1/EXCELVBA486.html

 【ローカルウィンドウ】
https://excel-ubara.com/excelvba4/EXCEL266.html
http://excelvba.pc-users.net/fol8/8_2.html

■７
以上を踏まえて整理するとこんな感じになります。（コンパイルエラーにならないことのみチェック済）

 ※※ 修正のためいったん削除 ※※

（もこな２） 2021/02/15(月) 19:18

残念ながら反応がなくなってしまいましたが、提示しておきます。

   Sub 一括取得_整理1()
      '// FileSystemObjectを使ってみる
      Dim folder As String
      Dim nowRow As Long, lastRow As Long
      Dim fso As Object
      Dim f As Object
      Dim shtSyuyaku As Worksheet

      Stop 'ブレークポイントの代わり

      '▼ダイアログを出して、ユーザーに処理するフォルダを選択してもらう
      With Application.FileDialog(msoFileDialogFolderPicker)
         If .Show = True Then
            folder = .SelectedItems(1)
         Else
            MsgBox "フォルダが選択されなかったので処理を中止します"
            Exit Sub
         End If
      End With

      '▼諸準備
      Set shtSyuyaku = ThisWorkbook.Sheets("入力用")
      Set fso = CreateObject("Scripting.FileSystemObject")
      nowRow = 2

      '▼指定されたフォルダにあるファイルを巡回して、Excelブックだったら開いて処理する
      Set shtSyuyaku = ThisWorkbook.Sheets("入力用")
      Set fso = CreateObject("Scripting.FileSystemObject")
      nowRow = 2
      For Each f In fso.GetFolder(folder).Files
         If LCase(fso.GetExtensionName(f.Name)) Like "xls*" Then
            With Workbooks.Open(f.Path).Sheets("入力用")
               lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

               If lastRow >= 4 Then
                  With .Range("A4", .Cells(lastRow, 15))
                     .Copy shtSyuyaku.Cells(nowRow, 1)  'コピペを実行
                     nowRow = nowRow + .Rows.Count      'コピペした行数を加算
                  End With
               End If

               .Parent.Close
            End With
         End If
      Next f
      MsgBox "完了"
   End Sub
   '-----------------------------------------------------------
   Sub 一括取得_整理2()
      '// Dir関数を使ってみる
      Dim folder As String, lastRow As Long, ファイル名 As String
      Dim 出力セル As Range: Set 出力セル = ThisWorkbook.Sheets("入力用").Range("A2")

      Stop 'ブレークポイントの代わり

      '▼ダイアログを出して､ユーザーに処理するフォルダを選択してもらう
      With Application.FileDialog(msoFileDialogFolderPicker)
          If .Show = True Then
              folder = .SelectedItems(1)
          Else
              MsgBox "フォルダが選択されなかったので処理を中止します"
              Exit Sub
          End If
      End With

      '▼指定されたフォルダにあるファイルを巡回して､Excelブックだったら開いて処理する
      ファイル名 = Dir(folder & "\*.xls?")
      Do Until ファイル名 = ""
         With Workbooks.Open(folder & "\" & ファイル名).Sheets("入力用")
            lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            If lastRow >= 4 Then
               With .Range("A4", .Cells(lastRow, 15))
                  .Copy 出力セル                               'コピペを実行
                  Set 出力セル = 出力セル.Offset(.Rows.Count)  'コピペした行数を加算
               End With
            End If

            .Parent.Close
         End With

         ファイル名 = Dir()
      Loop

      MsgBox "完了"
   End Sub

（もこな２） 2021/02/17(水) 21:35

アドバイスたくさんいただきありがとうございます、コメント返したつもりができていなくて更新できないままになっていました…
とりあえず、転記がうまくされないのは解決しましたので取り急ぎ報告です
（kaori） 2021/02/25(木) 10:01

■８
＞とりあえず、転記がうまくされないのは解決しましたので取り急ぎ報告です
無理にとは言いませんが、同じような悩みをもった方へのヒントになることもあろうかと思いますので、どのように解決したのか提示されてみては如何でしょうか。

また、同じく無理にとは言いませんが現状のコードを示してみてはどうでしょうか。
何点か冗長とおもえる部分の指摘をしましたし、正解は１つではありませんから、他の回答者さんから別アプローチでのアドバイスがあるかもしれません。

（もこな２） 2021/02/26(金) 17:42

コメント返信：

[ 一覧(最新更新順) ]

[[20210215095139]] 『複数の別ブックからデータを転記するマクロを作り』（kaori） ページの最後に飛ぶ

[[20210215095139]]　『複数の別ブックからデータを転記するマクロを作り』（kaori）　ページの最後に飛ぶ