フォルダ内の全てのExcelファイルから値をコピペするコードについて

エクセル2016を使っていますが、Ｃドライブ中の「2018」というフォルダにある、拡張子が「.xlsx」の全てのファイルから、データをエクセルファイルにコピペしたいと思います。
以前、この掲示板で質問させていただいたコードを修正し、以下のように修正して実行したところ、青くて丸いマークが回転してマクロが動いているように見えるのですが、貼り付け先に何も値が貼り付けられないままマクロが終了してしまいます。

どこに問題があるのか、ご教示願います。


Sub copy()

Dim FolderPath As String
FolderPath = "C:\2018"
Dim Filename As String
Dim Sh As Worksheet, ShL As Worksheet
Dim row As Long, baseRow As Long
Dim Files As Long, Count As Long

Set Sh = ActiveSheet
Filename = Dir(FolderPath & "¥*.xlsx")
baseRow = Cells(Rows.Count, "A").End(xlUp).row + 1
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

Do Until Filename = ""
Workbooks.Open FolderPath & "¥" & Filename
Set ShL = ActiveWorkbook.Sheets(1)
ShL.Range("1:2").Delete
row = ShL.UsedRange.Rows.Count
ShL.Range(Cells(3, 1), Cells(row, 3)).Copy Sh.Cells(baseRow, 2)
baseRow = baseRow + row
ShL.Parent.Close

Filename = Dir()
Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

No.5 回答者： WindFaller 回答日時： 2018/05/31 12:15

#4は、あくまでも試験用で、シートの状態など、お話の様子では、さっぱり分からないので、あえて作ったマクロです。

しかし、結果は、たいして前と変わらないです。

どうも、話を最初のそのご質問を作った時点に戻らないといけないような気がします。
私には見えていない部分があります。それは、エラーが発生する理由です。

(1)　初期化
>「一旦シートを何もない状態にもどしてよいですか」
これは、特に、初期化の問題ですが、最初から何が入った状態で始めるという前提がないと調べられないからです。実際は、ご質問者さんの選択に任せることになります。

(2)　最終行を見つける
>「データが見つかりません」もたまに出ます。
実際はコピーはしないということだと、こちらは解釈しています。
今回のマクロは、そのまま続行させています。

　 j = .Cells.SpecialCells(xlCellTypeLastCell).Row　'最終行を取る
If j <= 3 Then MsgBox "データが見つかりません", vbExclamation

> 貼り付け先の3行目からではなく、2行目から貼りつけられ、
今の段階では、データが見つかりません、としても、2行目～3行目までコピーしてしまいます。
それは、不要なのか必要なのか、2行の削除の命令がありましたが、それがどう生きているのか、こちらでは分からなかったからです。

With wb.Sheets(1)
'//　 最終行を取る命令が決まらない
'????
　 '*
　 If j >= 3 Then
　　 .Range(.Cells(3, 1), .Cells(j, 3)).Copy Acsh.Cells(i, 2)
　 End If
End With

とすれば、コピーしないで素通りしていきます。

(3) データのみをコピーさせるのか、罫線もコピーさせるのか。

>しかも最初の200行ほどは貼り付られるといっても罫線のみで値が入っていません。
j = .Cells.SpecialCells(xlCellTypeLastCell).Row
これは、確か、罫線のある場所も感知するコマンドです。 データがあるのに、データはコピーされないというのは、私には、その原因を解明させることはできません。それと、罫線自体をコピーさせるのかどうか、させないのでしたら、値のみをコピーさせる方法も選択の余地があります。

私は、あえて、UsedRangeを嫌ったのですが、また、やむを得ず、それを戻すことになろうかとは思います。ただし、どこに飛ぶのか分からないです。 UsedRange.Rows.Count というのは、時には有効ですが、私は使いません。行数が足りなくなるからです。
A列で、End(xlUp).Row などと使うのが、それは使えないような気がするのです。根拠はありません。これらは、データのそれぞれ範囲が分かっていたらの話だからです。

(4) エラーの原因の追求
　「青くて丸いマークが回転してマクロが動いているように見える」「貼り付け先に何も値が貼り付けられないままマクロが終了してしまいます」
　間違いなくエラーが発生しているのですが、そのような状況下でエラーが発生する原因は、多くはシートが壊れている可能性が強いわけで、マクロからではほぼ回復は無理ではないかと思います。

(5)今後の予定

実際、どんな表なのかデータをコピー&ペーストしているのか、回答者側では、さっぱり分からずにいるわけです。なぜ、元のコードでエラーが発生しているブックを、除外する方法はマクロでは不可能だと思います。

現実に、目の前でどういう状態か見ていれば、ストップ(Stop)を掛けて調べることは可能ですが、コピー&ペーストマクロでは、今の段階では、根本的には変わらないと思います。

ただ、今の段階で、
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

もう2つぐらい、制御コマンドと、エラー回避を付ける必要性があるとは思います。

それと、趣旨をご理解しないままでは、試験用のマクロを繰り返すのは、ちょっと無理があるかもしれません。

この回答へのお礼

何度も付き合っていただき、ありがとうございます。
前回、ファイルは開くもののコピペ自体されていないと書きましたが、申し訳ないのですが、間違いでした。（貼り付け先シートの1200行辺りから行われていました）
何点かシンプルにして実行してみたところ、コピペはされましたが、以下の問題があることがわかりました。

●　CドライブはNTFSなのでファイル名順に取り込まれるはずが、完全にはそのようになっていない。ファイル名は001、002・・280というような数字で001から取り込まれそうなものの078から172まで順番に取り込まれ、1行空白行ができた後、183・・280と取り込み、そのまま（空白行ができず）001・・077と取り込んでいるようです。

●　上にも書きましたが、貼り付け先にできる空白行は1行目だけのはずが、途中にも一つできてしまっている。（172ファイルを取り込んだあとの行です）

どこに問題があるのか、ご教示いただけると幸いです。

Sub copy()

（略）

Set Sh = ActiveSheet
Filename = Dir(FolderPath & "\*.xlsx")
baseRow = Sh.Cells(Rows.Count, "A").End(xlUp).row + 1
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

Do Until Filename = ""
Set wb = Workbooks.Open(FolderPath & "\" & Filename)
With wb.Sheets(1)
Rows("1:2").Delete Shift:=xlUp
Rowcnt = .UsedRange.Rows.Count
.Range(Cells(1, 1), Cells(Rowcnt, 3)).Copy Sh.Cells(baseRow, 1)
End With

baseRow = baseRow + Rowcnt
wb.Close False

Filename = Dir()
Loop

Application (略）

End Sub

お礼日時：2018/06/01 10:57

No.4 回答者： WindFaller 回答日時： 2018/05/26 19:24

やはり、一度、全文を書いてみて、どんな様子か、VBAの一部の切り貼りだけでは分からないものがあるかもしれませんね。

細かい說明は省きますが、'* とあるのが、チェック項目です。
元のマクロは、B列に貼り付けるようになっていますが、そこがなんとなく問題を起こしているような気がします。以下のマクロは、あくまでも、こちらが確認できるようにするために作ったマクロで、そのままでは余分な部分があります。なお、新規のシートでお試しください。

'//
Sub ArrangedTestMacro1()
Dim wb As Workbook
Dim shL As Worksheet
Dim RowCnt As Long
Dim FileName As String
Dim FolderPath As String: FolderPath = "C:\Temp"
Dim i As Long, j As Long '元:baseRow

Dim Acsh As Worksheet

Application.Calculation = xlCalculationManual

Set Acsh = ActiveSheet 'アクティブシートの登録
'*
If WorksheetFunction.CountA(Acsh.UsedRange) > 0 Then
　If MsgBox("一旦シートを何もない状態にもどしてよいですか？", vbOKCancel) = vbCancel Then Exit Sub
　Acsh.UsedRange.Clear
End If
Application.ScreenUpdating = False

i = Acsh.Cells(Rows.Count, 2).End(xlUp).Row + 1　'B列で最終行＋1を取る
FileName = Dir(FolderPath & "\*.xlsx")
'*
If FileName = "" Then MsgBox "Check:" & FolderPath

Do Until FileName = ""
　Set wb = Workbooks.Open(FolderPath & "\" & FileName)
　With wb.Sheets(1)
　 j = .Cells.SpecialCells(xlCellTypeLastCell).Row　'最終行を取る
　 '*
　 If j <= 3 Then MsgBox "データが見つかりません", vbExclamation
　 .Range(.Cells(3, 1), .Cells(j, 3)).Copy Acsh.Cells(i, 2)
　End With
　wb.Close False
　'貼付け後
　i = Acsh.Cells(Rows.Count, 2).End(xlUp).Row + 1　'B列で最終行＋1を取る
　'*
　If i < 3 Then
　 i = i + j
　End If
　FileName = Dir()
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

この回答へのお礼

ありがとうございます。
実行したところ、「一旦シートを何もない状態にもどしてよいですか」というメッセージは表示され、「データが見つかりません」もたまに出ます。

そして、データが一応は貼り付けられるのですが（全部のファイルからコピペできているかは不明です）、貼り付け先の3行目からではなく、2行目から貼りつけられ、しかも最初の200行ほどは貼り付られるといっても罫線のみで値が入っていません。


ちなみにですが、前回、修正していただいたコードですが、Application.ScreenUpdating = Falseを外して実行したところ、貼り付け先の各ファイルは次々と開いているようですが、コピペが行われていないようです。
結果として、マクロの実行後もコピペが行われていない空白セルのままで終了してしまっているようです。

お礼日時：2018/05/30 15:15

No.3 回答者： めぐみん_ 回答日時： 2018/05/25 16:33

Do Until Filename = ""

Workbooks.Open FolderPath & "\" & Filename
Debug.Print ActiveWorkbook.Name ' ★追加
Set ShL = ActiveWorkbook.Sheets(1)

★を追加してみて『目的のBookを得ているのか』とか、実際書きだしていくしかないのかも？
あとはコピー元のセル範囲のアドレスを書き出してみるとか、変数の変化を書き出すとか、コツコツ調べてみるのが宜しいのではないでしょうか。

この回答へのお礼

ありがとうございます。
申し訳ないのですが、書き出し方がわからないというか、書いていただいたコードを追記しても、何も変わりませんでした。

お礼日時：2018/05/29 10:37

No.2 回答者： WindFaller 回答日時： 2018/05/24 20:42

私が書いたコードではなさそうですが

Row という変数は、使わないでください。Rangeのプロパティにすであるからです。

Dim wb As Workbook
Dim shL As Worksheet
Dim RowCnt As Long　'←Row を変えました。

Do Until Filename = ""
　Set wb = Workbooks.Open(FolderPath & "\" & Filename)
　With wb.Sheets(1)
　 .Range("1:2").Delete　'行を削除すれば遅くなるけれど？＊
　 RowCnt = .UsedRange.Rows.Count　　'←こんな書き方 「.（ピリオド)」を付ける
　 .Range(.Cells(3, 1), .Cells(RowCnt, 3)).Copy sh.Cells(baseRow, 2) '**
　End With
　baseRow = baseRow + RowCnt + 1　'←ふつうはこうは書かないです。
　'#1さんのコードを応用すれば良いです。
　wb.Close False　'保存しない場合は、False
　Filename = Dir()
Loop
（上記は実行はしてみていません)
＊単に、Copy の範囲や行数を取るためでしたら、他に方法があります。また、UsedRange ですと、思わぬ場所まで行く時があります。ずっと間が桂馬になっても続いているなら、
任意の「セル.CurrentRegion」です。

** Range と Cells は、概ね、親オブジェクトはシートですが、異母兄弟なのだと思いますが、仲があまりよくありません。これは、初期の開発時期に、開発に2チームがあって、お互いに主張した結果が、独立した仕様になったのだと思っています。だから、Range の親オブジェクトを設定しても、Cells 側にも、親オブジェクトを設定してあげないといけないというわけです。Excelには、随所に、異母兄弟のような似たオブジェクトが存在しています。私が、VBAをなかなか覚えられなかった原因です。

この回答へのお礼

ありがとうございます。
教えていただいたとおりに修正しましたが、相変わらず、動き出したようには見えるものの、コピペがされないまま終了してしまいます。
どこが問題なんでしょうか。

お礼日時：2018/05/25 13:03

No.1 回答者： めぐみん_ 回答日時： 2018/05/24 19:51

＞baseRow = Cells(Rows.Count, "A").End(xlUp).row + 1

baseRow = Sh.Cells(Rows.Count, "A").End(xlUp).row + 1

＞ShL.Range(Cells(3, 1), Cells(row, 3)).Copy Sh.Cells(baseRow, 2)

ShL.Range(ShL.Cells(3, 1), ShL.Cells(row, 3)).Copy Sh.Cells(baseRow, 2)


Cells に対しどのシートのセルなのかを明確にしてみるとか？

この回答へのお礼

ありがとうございます。
そのようにしてみましたが、やはりコピペがされないまま終了してしまいました。

お礼日時：2018/05/25 11:57