エクセル2016を使っていますが、Cドライブ中の「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
A 回答 (5件)
- 最新から表示
- 回答順に表示
No.5
- 回答日時:
#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
No.4
- 回答日時:
やはり、一度、全文を書いてみて、どんな様子か、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を外して実行したところ、貼り付け先の各ファイルは次々と開いているようですが、コピペが行われていないようです。
結果として、マクロの実行後もコピペが行われていない空白セルのままで終了してしまっているようです。
No.3
- 回答日時:
Do Until Filename = ""
Workbooks.Open FolderPath & "\" & Filename
Debug.Print ActiveWorkbook.Name ' ★追加
Set ShL = ActiveWorkbook.Sheets(1)
★を追加してみて『目的のBookを得ているのか』とか、実際書きだしていくしかないのかも?
あとはコピー元のセル範囲のアドレスを書き出してみるとか、変数の変化を書き出すとか、コツコツ調べてみるのが宜しいのではないでしょうか。
ありがとうございます。
申し訳ないのですが、書き出し方がわからないというか、書いていただいたコードを追記しても、何も変わりませんでした。
No.2
- 回答日時:
私が書いたコードではなさそうですが
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をなかなか覚えられなかった原因です。
ありがとうございます。
教えていただいたとおりに修正しましたが、相変わらず、動き出したようには見えるものの、コピペがされないまま終了してしまいます。
どこが問題なんでしょうか。
No.1
- 回答日時:
>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 に対しどのシートのセルなのかを明確にしてみるとか?
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・14歳の自分に衝撃の事実を告げてください
- ・架空の映画のネタバレレビュー
- ・「お昼の放送」の思い出
- ・昨日見た夢を教えて下さい
- ・ちょっと先の未来クイズ第4問
- ・【大喜利】【投稿~10/21(月)】買ったばかりの自転車を分解してひと言
- ・メモのコツを教えてください!
- ・CDの保有枚数を教えてください
- ・ホテルを選ぶとき、これだけは譲れない条件TOP3は?
- ・家・車以外で、人生で一番奮発した買い物
- ・人生最悪の忘れ物
- ・【コナン30周年】嘘でしょ!?と思った○○周年を教えて【ハルヒ20周年】
- ・ハマっている「お菓子」を教えて!
- ・最近、いつ泣きましたか?
- ・夏が終わったと感じる瞬間って、どんな時?
- ・10秒目をつむったら…
- ・人生のプチ美学を教えてください!!
- ・あなたの習慣について教えてください!!
- ・牛、豚、鶏、どれか一つ食べられなくなるとしたら?
- ・都道府県穴埋めゲーム
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
条件に応じて特定の行を非表示...
-
Excel2007で、太字にした行のみ...
-
Excel にて非表示行を探すワー...
-
excel ある部分だけをコピペし...
-
エクセルのマクロで条件によっ...
-
Excel(VBA)データ入力に応じて...
-
wordのvbaでハイパーリンク設定...
-
Excel2007 セルを右方向に削除...
-
エクセル VBA 小数点を含む数字...
-
Excelのマクロについて
-
Excelアルファベットを含む数値...
-
「マクロ」の足し算の式を教え...
-
Excelでセル内の数式は残し値だ...
-
yyyy/mm/ddの日付に一括変換す...
-
Excelのシートを、まとめて表示...
-
エクセルの複数シートの保護を...
-
エクセルでファイルを開いたと...
-
Excelで金銭出納帳。繰越残高を...
-
エクセルVBAでパスの¥マークに...
-
エクセルで複数設定したハイパーリンク先...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
条件に応じて特定の行を非表示...
-
Excel2007で、太字にした行のみ...
-
エクセル VBA 小数点を含む数字...
-
エクセルで全ての数字間にカン...
-
Excel(VBA)データ入力に応じて...
-
excel ある部分だけをコピペし...
-
Excelでセル内の数式は残し値だ...
-
Excel にて非表示行を探すワー...
-
整数行を残し小数点の行を削除...
-
Excel2007 セルを右方向に削除...
-
wordのvbaでハイパーリンク設定...
-
「マクロ」の足し算の式を教え...
-
エクセル2003でマクロをおこな...
-
エクセル マクロ オートシェ...
-
並べ替えのマクロで対象行の範...
-
エクセルで作る名簿をいつもあ...
-
yyyy/mm/ddの日付に一括変換す...
-
エクセルで連番をマクロで
-
値貼り付けをしても書式も貼り...
-
Excelで周期的に列を削除する方法
おすすめ情報