Do Loopの処理結果が思うように得られません。

質問

VBAの知識がなく、コピペで作業しています。
笑わないで見てください。

作業内容は
「集計用フォルダ内にあるファイル（60個くらいあります）の情報を取得してデータベース化する」
です。

下記のプログラムを作ってみたのですが、ThisWorkbookに各ファイルのデータが
一行ずつずれて貼り付けられてしまい、最終行の一つ下に貼り付けられていません。

画面を見ていると、ファイルは一つずつ開いて閉じてを繰り返しているのですが、
貼り付けは一括で行われます。

ThisWorkbookの扱いで、散々苦労して作ったのですが、あと一歩というところで
つまづいてしまいました。

アドバイス、よろしくお願いいたします。

Sub フォルダ内エクセルファイル値取り出し()

Dim FName As String
Dim FPath As String
Dim cnt As Integer
Dim r As Long

'画面更新オフ
Application.ScreenUpdating = False

'累積データがある列のデータ下端を取得
cnt = Cells(Rows.Count, 1).End(xlDown).Offset(1, 0).Row

FPath = "C:\Documents and Settings\******\デスクトップ\集計用フォルダ(このフォルダは書込み専用です）" '対象フォルダのパス
ChDir FPath
FName = Dir("*.xls")

Do While FName <> ""
Workbooks.Open FName

Worksheets(1).Range(Selection, ActiveCell.SpecialCells(xlLastCell)) _
.Copy Destination:=ThisWorkbook.Sheets(1).Cells(cnt, 1)

cnt = cnt + 1

ActiveWorkbook.Close
FName = Dir()
Loop

'画面更新オン
Application.ScreenUpdating = True

End Sub

回答No.3

cj_mover · ベストアンサー

＃２、ｃｊです。＃２への追加レスです。

UsedRange プロパティや"LastCell"では、場合によっては、
有意なデータ範囲ではなく、セルの塗りつぶしを適用した範囲を返してしまうことがあります。
そこで、もう一案、Ａ列を基準にデータの最下行を採る方法で統一したものを挙げておきます。
（＃この方が意図に沿うようような気がします。）

▼▼マークの行はオプションですが、
ThisWorkbookが、フォルダFPathにある場合には必要な記述です。
フォルダが異なることが保証されるなら、▼▼マークの２行は削除して構いません。

Sub Re8319935b()

　　Dim FName As String
　　Dim FPath As String
　　Dim cnt As Long
　　Dim r As Long

　　FPath = "C:\Documents and Settings\******\デスクトップ\集計用フォルダ(このフォルダは書込み専用です）" '対象フォルダのパス
　　ChDir FPath
　　FName = Dir("*.xls")

　　' ' 画面更新オフ
　　Application.ScreenUpdating = False

　　With ThisWorkbook.Sheets(1)　　'　　★出力先シートへの参照を確保
　　　　Do While FName <> ""
　　　　　　If FName <> ThisWorkbook.Name Then　　'　　▼▼
　　　　　　　　cnt = .Cells(Rows.Count, 1).End(xlUp).Row + 1　　'　　★
　　　　　　　　Workbooks.Open FName
　　　　　　　　ActiveSheet.UsedRange.Resize(Cells(Rows.Count, 1).End(xlUp).Row).Copy Destination:=.Cells(cnt, 1)　　'　　★
　　　　　　　　ActiveWorkbook.Close SaveChanges:=False　　'　　★
　　　　　　　　FName = Dir()
　　　　　　End If　　'　　▼▼
　　　　Loop
　　End With

　　' ' 画面更新オン
　　Application.ScreenUpdating = True

End Sub

お礼

cj_moverさま

先程は、ciと書いてしまって、失礼しました。

>▼▼マークの行はオプションですが、
>ThisWorkbookが、フォルダFPathにある場合には必要な記述で>す。
>フォルダが異なることが保証されるなら、▼▼マークの２行は削除>して構いません。

わぁ～ぁ！、ここまで考えられているんですね。
実は最初に同じフォルダ内に作って動作させたところ、自分のファイルも読み込んでしまったので、フォルダの外に置くようにしました。しかし、それだと何かと不便だったので、この作業は大変助かります。このまま使わせていただきます。

で、試したところ

成功しました～ぁ！！＼(^o^)／

叱られても笑われても、思うように動いた時の嬉しさは
何とも言えないものがあるので、私はこれからもいろいろと
作り続けたいです。

cjさんのようには到底なれないにしても、超初心者は
初心者なりに、せめて質問だけでも、きちんと出来るように
したいものだと思いました。

テキストには書いていないような知識は経験から得たもの
なのでしょうか。

これからもテキスト片手に、いろいろな物を作っていきたいと
思っています。頑張ります。

本当に有難うございました。
cjさんの親切・丁寧・我慢強さに心より感謝します。

回答No.4

mt2008

ここを直してみて下さい

誤：cnt = Cells(Rows.Count, 1).End(xlDown).Offset(1, 0).Row
↓
正：cnt = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

お礼

あっ、すみません、それ、私の書き間違いです。
お手数おかけして、すみませんでした。

回答No.2

cj_mover

こんにちは。

うまく行かないコードの提示だけでは、本当のところ、どうしたいのか、
こちらの理解も到りません。
Selection（セル範囲）をRangeの引数に指定している件ですが、
対象ブックを最後に保存した時に選択されていたセル範囲、
が、Selection、ということになりますが、
そこに何か意味を持たせたいのでしょうか？
Selection、というのは、ユーザー操作を制限するようなシステムを目指しても
変更されてしまう、あてにならないものです。
（＃実物を見ない限りは、Selection ≒ UnKnown、ですね）
という理由で、何か勘違いされているのかな、と考えます。

もしも、それぞれのブックの特定の範囲をコピペしたい、ということであれば、
その、特定の仕方を、実際のシートを見たことがない者にも解る様に、
文章で、説明してみてください。

取り敢えず、
元のコードをなるべく残しつつ、
UsedRange プロパティを使って、各シートの使われたセル範囲を採り、
ひとつずつ下に貼付けをするように書き換えてみました。
慣れないプロパティなどは、VBAのヘルプ等で、まず確認、するようにしてください。

Sub Re8319935()

　　Dim FName As String
　　Dim FPath As String
　　Dim r As Long

　　FPath = "C:\Documents and Settings\******\デスクトップ\集計用フォルダ(このフォルダは書込み専用です）" '対象フォルダのパス
　　ChDir FPath
　　FName = Dir("*.xls")

　　' ' 画面更新オフ
　　Application.ScreenUpdating = False

　　With ThisWorkbook.Sheets(1)　　'　　★出力先シートへの参照を確保
　　　　Do While FName <> ""
　　　　　　Workbooks.Open FName
　　　　　　ActiveSheet.UsedRange.Copy Destination:=.UsedRange.Cells(.UsedRange.Count + 1)　　'　　★
　　　　　　ActiveWorkbook.Close
　　　　　　FName = Dir()
　　　　Loop
　　End With

　　' ' 画面更新オン
　　Application.ScreenUpdating = True

End Sub

補足

説明不足ですみません。
>各シートの使われたセル範囲を採り、
>ひとつずつ下に貼付けをするように
そのとおりの作業内容です。

それでci_moverさんが作られたコードを
貼り付けてみたのですが、
何も貼り付けられないのですが・・・。

Pathの確認をし、フォルダの中にファイルがあり、
そのファイルにデータが入っているのを確認しました。

保存されている状態から、UsedRangeが正しく選択
されているのは確認できました。が、ThisWorkbookに
貼り付けされていませんでした。

vbaについてはこれではいけないと思い、先週から本を買って
勉強を始めました。ざっと読んで必要そうなところを
修正したつもりなのですが、理解不足がバレバレで
すみません。

これに懲りずによろしくお願いします。

回答No.1

play_with_you

そもそも
＞'累積データがある列のデータ下端を取得
＞cnt = Cells(Rows.Count, 1).End(xlDown).Offset(1, 0).Row
これ、エラーになりませんか？xlDownじゃなくてxlUpでしょ。

＞画面を見ていると、ファイルは一つずつ開いて閉じてを繰り返しているのですが、
＞貼り付けは一括で行われます。
処理中はScreenUpdatingがオフになっているから。