どれくらい容量を増やせばE:ドライブにコピペ可能？

質問

J:ドライブからE:ドライブに最新の（2週間以内）のファイルをコピペしていますが
途中でE:ドライブが満杯でコピペ出来なくなりました。

CD /D %TEMP%
C:\Windows\System32\Robocopy.exe J:\ E:\ /S /MAXAGE:14 /XD "System Volume Information" "$RECYCLE.BIN"

後どれくらいの容量を増やせばE:ドライブにコピペ出来るかはチェックできますか　？

とりあえずE:の不要そうなファイルを削除して完了まで進めたい。

回答No.19

kkkkkm · ベストアンサー

> type:=1 でも　Type:=2としなくても良いと言う事になりますよね　？

type:=1にしないとボックスへの入力時に数字以外の規制をしてくれなくなります。

多分ですが、エクセルが受ける側に合わせて型変換してくれているのではと思います。
たとえば、普通のInputBoxは数字を入れても戻り値はStringですが、Longで受けてもエラーにはならないのでそんな感じです。
Application.InputBoxは指定した型が戻り値です。

「型変換するよ」ということで以下のようにしておくと違和感がないかもしれません。

Temp = CStr(Application.InputBox(prompt:="何日前からのファイルをコピペしますか　？", Title:="日数指定　(Max=14)", Type:=1))

ちなみに
FixDay = CByte(Temp)
を
FixDay = Temp
にしてもエラーになりません。

多分、他の言語だと今回のように型変換しない場合は、全てのパターンでエラーだと思います。

お礼

Dim FixDay As Byte　でType:=1で、以下のようにCstrに変えたら
Temp = CStr(Application.InputBox(prompt:="何日前からのファイルをコピペしますか　？", Title:="日数指定　(Max=14)", Type:=1))

(確かに「型変換するよ」ということでCStrにしておく方が違和感が有りません。）

以下で、オーバーフローのエラーが出ました。
'日付指定はマイナス (プラスで指定したら符号反転）
If FixDay > 0 Then FixDay = -FixDa

そこで以下のように変えたらうまく処理できるようになりました。

'-----------------------------------------
Dim FixDay As Single

'キャンセルを判断するのに一度文字列(temp)を利用する
Dim Temp As String

Do While flag = False
'CStr関数は、引数をString型（文字列型）に変換します。
Temp = CStr(Application.InputBox(prompt:="何日前からのファイルをコピペしますか　？", Title:="日数指定　(Max=14)", Type:=1))

'ドライブ指定でキャンセルを選択した場合 ----> キャンセル = False
'cancel を判断するためtempは文字型を指定
If Temp = "False" Then
MsgBox "処理を終了します。"
Set objFSO = Nothing
Exit Sub

'Val関数は、文字列を数値に変換することができます。
ElseIf Abs(Val(Temp)) = 0 Then
MsgBox ("指定日数がゼロは有りえません。") & vbCrLf & _
"指定日数を確認してください。"

ElseIf Abs(Val(Temp)) > 14 Then
MsgBox "日付指定の最大日数は、１４日以内です。" & vbCrLf & _
"指定日数を確認してください。"

Else
flag = True
'コピペする日付を指定
FixDay = Val(Temp) 'CByte関数は、引数を評価してバイト型「0～255」を返す。
End If

Loop

'日付指定はマイナス (プラスで指定したら符号反転）
If FixDay > 0 Then FixDay = -FixDay

'-------------------------------------------------
　これで本当に一区切りついたと思います。

長々とお世話になりありがとうございます。

補足

すいません。

If FixDay > 0 Then FixDay = -FixDa
を
If FixDay > 0 Then FixDay = -FixDay
に訂正します。

最後のｙが抜けていました。

回答No.18

kkkkkm

> inputboxでキャンセルをクリックした場合とゼロを入力し場合を区別したい

一度文字列で受けてキャンセル判断してはいかがですか。

Dim Temp As String

Do While flag = False
Temp = Application.InputBox(prompt:="何日前からのファイルをコピペしますか　？", Title:="日数指定　(Max=14)", Type:=1)
'ドライブ指定でキャンセルを選択した場合
If Temp = "False" Then
MsgBox "処理を終了します。"
Set objFSO = Nothing
Exit Sub

ElseIf Abs(CByte(Temp)) = 0 Then
MsgBox ("指定日数がゼロは有りえません。") & vbCrLf & _
"指定日数を確認してください。"

ElseIf Abs(CByte(Temp)) > 14 Then
MsgBox "日付指定の最大日数は、１４日以内です。" & vbCrLf & _
"指定日数を確認してください。"

Else
flag = True
FixDay = CByte(Temp)
End If

Loop

お礼

kkkkkmさん、早速　回答いただきありがとうございます。

教えていただいたコードでうまく処理出来るようになりました。
コードは、subにして他にも使えそうなので勉強になります。

訂正前のコードでも
If FixDay = "False" Then で良かったのですね。

思うのですが、
temp = を Type:=1 としているのでtempは数値で指定する事になりますが
Dim Temp As String　では、先に文字列で指定されます。

これは、矛盾するように思うのですが　？

dim の宣言の方が優先されると判断すれば
type:=1 でも　Type:=2としなくても良いと言う事になりますよね　？
（type:=2 で　Dimの指定の文字列と同じになる）

FixDayの問題も解決したので一区切りつけたいと思います。

長々とお世話になりありがとうございます。

回答No.17

kkkkkm

MsgBox "終了"
Exit Sub
は
MsgBox "終了"
Set objFSO = Nothing
Exit Sub
にしてた方がいいかもです。

回答No.16

kkkkkm

(5桁で指定)
6桁でした。
@を0にしたら多少はましになるかもしれません。見にくい気もしますが。

お礼

kkkkkmさん、コードの見直しで何度もアドバイス頂きありがとうございます。

確かに、散らばっていたinputの判断は
一箇所にしたほうが判りやすく
3つInputしてその後に「送る側が存在しない」とか言われたら先に言ってよとなりますね。

MSGBOXの件ですが、確かの＠より０の方がキレイに揃いますが
頭に０が並ぶのは普通目にしないので＠の方を採用したいと思います。
又、MBの数値は３桁区切りのほうが好みなので書式を変更しました。

VBなどでは、数値を3けた区切りの文字列に変換する事が出来るそうですが
VBAで調べても参考記事がヒットしないので普通に「#,###」で数値を３桁区切りに変更しました。
(表示されるmsgboxの表示を見ると
　わざわざ数値を3けた区切りの文字列に変換する必要も無さそうに思えます。)

https://imgur.com/ZTbdGbj

個人的には、長々とご指導願いましたが
完成かな？と思っていたのですが、
以下のコードでまた煮詰まりました。

現在のコードでは、
inputboxでキャンセルをクリックした場合とゼロを入力し場合を区別したいのですが
キャンセルを押してもゼロが入力されたと解釈されています。

StrPtr(FixDay) = で　ゼロ(０)を指定しているので当然でしょうが
ここはどう変えれば良いでしょうか　？

なお、Dim FixDay As Byte　に変更しました。
（Singleを使わなくても0～255までの整数であるByteで十分と判断しました。）

'コピペする日付を指定
Do While flag = False
FixDay = Application.InputBox(prompt:="何日前からのファイルをコピペしますか　？", Title:="日数指定　(Max=14)", Type:=1)

'ドライブ指定でキャンセルを選択した場合
If StrPtr(FixDay) = 0 Then
MsgBox "処理を終了します。"
Set objFSO = Nothing
Exit Sub

ElseIf Abs(FixDay) = 0 Then
MsgBox ("指定日数がゼロは有りえません。") & vbCrLf & _
"指定日数を確認してください。"

ElseIf Abs(FixDay) > 14 Then
MsgBox "日付指定の最大日数は、１４日以内です。" & vbCrLf & _
"指定日数を確認してください。"

Else
flag = True
End If

Loop

'---------------------------------

細かな点を見直すとまだまだアラが出てきそうですが
FixDayの問題が解決すれば一区切りつけて
運用上で何か又改造したく成ったら新しく質問を立ち上げたいと思っています。

'-------------------------------------
Option Explicit
Dim FixDay As Byte

Sub フォルダとファイル一覧取得_階層考慮()
Dim objFSO As FileSystemObject
Dim strDir As String

Dim flag As Boolean '条件付き有限ループ用フラグ

flag = False 'flagの初期値は、「false」だがあえて宣言

Set objFSO = New FileSystemObject

'送る側のドライブ指定
Dim FrmDir As String
Do While flag = False
FrmDir = Application.InputBox(prompt:="どこから (J)", Title:="送る側のドライブレター", Type:=2)

'ドライブ指定でキャンセルを選択した場合
If FrmDir = "False" Then
MsgBox "処理を終了します。"
Set objFSO = Nothing
Exit Sub

ElseIf FrmDir Like "*[!a-zA-Zａ-ｚＡ-Ｚ]*" Then
MsgBox "送る側のドライブレターは、アルファベットで指定してください。"

ElseIf Not objFSO.FolderExists(FrmDir & ":\") Then
MsgBox ("送り先のドライブレターは存在しません。") & vbCrLf & _
"ドライブが接続されているか？確認してください。"
Else
flag = True
End If
Loop

FrmDir = FrmDir & ":\"

'もう一度判断させる（先の判断でTrueになったので元に戻す)
flag = False

'保存側のドライブ指定
Dim ToDir As String
Do While flag = False
ToDir = Application.InputBox(prompt:="どこへ　　(E)", Title:="保存側のドライブレター", Type:=2)

'ドライブ指定でキャンセルを選択した場合
If FrmDir = "False" Then
MsgBox "処理を終了します。"
Set objFSO = Nothing
Exit Sub

ElseIf ToDir Like "*[!a-zA-Zａ-ｚＡ-Ｚ]*" Then
MsgBox "保存先のドライブレターは、アルファベットで指定してください。"

ElseIf Not objFSO.FolderExists(ToDir & ":\") Then
MsgBox ("保存側のドライブレターは存在しません。") & vbCrLf & _
"ドライブが接続されているか？確認してください。"
Else
flag = True
End If
Loop

ToDir = ToDir & ":\"

'送る側と保存側のドライブが同じなら処理を終了
If FrmDir = ToDir Then
MsgBox "送り先と保存先のドライブが同じです。" & vbCrLf & _
"指定ドライブを再確認してください。" & vbCrLf & _
"処理を中止します。"
Exit Sub
End If

'もう一度判断させる（先の判断でTrueになったので元に戻す)
flag = False
Stop

'コピペする日付を指定
Do While flag = False
FixDay = Application.InputBox(prompt:="何日前からのファイルをコピペしますか　？", Title:="日数指定　(Max=14)", Type:=1)

'ドライブ指定でキャンセルを選択した場合
If StrPtr(FixDay) = 0 Then
MsgBox "処理を終了します。"
Set objFSO = Nothing
Exit Sub

ElseIf Abs(FixDay) = 0 Then
MsgBox ("指定日数がゼロは有りえません。") & vbCrLf & _
"指定日数を確認してください。"

ElseIf Abs(FixDay) > 14 Then
M

回答No.15

kkkkkm

画像添付し忘れました。

回答No.14

kkkkkm

ループの中で調べるのは以下のような感じにしたらどうかなと思ってました。
正しいデータを入れるかキャンセルするまで入力を促します。

3つInputしてその後に「送る側が存在しない」とか言われたら先に言ってよってなりそうです。

Set objFSO = New FileSystemObject

Dim FrmDir As String
'送る側のドライブ指定
Do While flag = False
FrmDir = Application.InputBox(prompt:="どこから (J)", Title:="送る側のドライブレター", Type:=2)
If FrmDir = "False" Then
MsgBox "終了"
Exit Sub
ElseIf FrmDir Like "*[!a-zA-Zａ-ｚＡ-Ｚ]*" Then
MsgBox "送る側のドライブレターは、アルファベットで指定してください。"
ElseIf Not objFSO.FolderExists(FrmDir & ":\") Then
MsgBox ("送り先のドライブレターは存在しません。") & vbCrLf & _
"ドライブが接続されているか？確認してください。"
Else
flag = True
End If
Loop

MsgBoxの件

TABとFormatでスペースを使った例(5桁で指定)

MsgBox "送る側の総容量" & Chr(9) & "=" & Format(CSize, "@@@@@@") & " MB" & vbCrLf & _
"　　　　　　　　" & Chr(9) & "　" & Format(Cize_GB, "@@@@@@") & " GB" & vbCrLf & _
"保存側の空き容量" & Chr(9) & "= " & Format(FDS, "@@@@@@") & " GB"

プロポーショナルフォントなので微妙にずれます。
ぴったりにしたければユーザーフォームで作ると思います。

回答No.13

kkkkkm

> 間違った入力をすると全てマクロ終了とするのでイマイチ納得はしていません。

Do While ～ Loopを使うとかありますね。
(GoTo文を使う手もありますが、お勧めしません)

条件付き有限ループ
http://officetanaka.net/excel/vba/tips/tips183.htm

追加でInputBoxでキャンセルが押されたときの処理を加えないと途中でやめられません。
先に回答したInputBoxメソッドを紹介したページを参照してください。

送る側と保存側の指定が同じ時の処理がないような感じです。

フォルダの存在確認ですが

MsgBox ("指定のフォルダは存在しません")

で、メッセージが送る側と保存側が同じなので、これが出たときにどちらが違うのか迷いました。
InputBoxのそれぞれのループの中で調べてもいいかもしれません。

For ii = 1 To lc
CSize = WorksheetFunction.Sum(Range("E1:E" & ii))
Next

ですがSumは範囲の合計ですからループせずに

CSize = WorksheetFunction.Sum(Range("E1:E" & lc))

でいいと思います

合計数ですが、個々のサイズをRoundUpしているので

本来の合計9.5Mの結果が(さほど大きくないファイルで12個)

総容量18M
　　　1G

という結果になりました。

位置合わせはスペースかタブChr(9)でやると思います。

お礼

kkkkkmさん、アドバイス頂いた内容についてコードの修正をしました。

（ちゃんと修正されているかは自信が有りません....）

＞位置合わせはスペースかタブChr(9)でやると思います。

思っている事を伝えるのが難しいので
参考画像を添付します。
（これで解ってもらえれば良いのですが、
　　無理そうなら諦めます。）

https://imgur.com/kPmmkRj

以下、修正後のコード

'---------------　
Option Explicit
Dim FixDay As Integer

Sub フォルダとファイル一覧取得_階層考慮()
Dim objFSO As FileSystemObject
Dim strDir As String

Dim flag As Boolean '条件付き有限ループ用フラグ

flag = False 'flagの初期値は、「false」だがあえて宣言

Dim FrmDir As String
'送る側のドライブ指定

Do While flag = False
FrmDir = Application.InputBox(prompt:="どこから (J)", Title:="送る側のドライブレター", Type:=2)

If FrmDir Like "*[!a-zA-Zａ-ｚＡ-Ｚ]*" Then
MsgBox "送る側のドライブレターは、アルファベットで指定してください。"
Else
flag = True
End If
Loop

FrmDir = FrmDir & ":\"

'もう一度判断させる（先の判断でTrueになったので元に戻す)
flag = False

Dim ToDir As String
'保存側のドライブ指定
Do While flag = False
ToDir = Application.InputBox(prompt:="どこへ　　(E)", Title:="保存側のドライブレター", Type:=2)

If ToDir Like "*[!a-zA-Zａ-ｚＡ-Ｚ]*" Then
MsgBox "保存先のドライブレターは、アルファベットで指定してください。"
Else
flag = True
End If
Loop

ToDir = ToDir & ":\"

'コピペする日付を指定
FixDay = Application.InputBox(prompt:="何日前からのファイルをコピペしますか　？", Title:="日数指定　(Max=14)", Type:=1)

'日付指定の最大をチェック
If Abs(FixDay) > 14 Then
MsgBox "日付指定の最大日数は、１４日以内です。"
Exit Sub
End If

'日付指定はマイナス (プラスで指定したら符号反転）
If FixDay > 0 Then FixDay = -FixDay

Set objFSO = New FileSystemObject

If Not objFSO.FolderExists(FrmDir) Then
MsgBox ("送り先のドライブレターは存在しません。") & vbCrLf & _
"ドライブが接続されているか？確認してください。" & vbCrLf & _
"処理を中止します。"
Exit Sub
End If

If Not objFSO.FolderExists(ToDir) Then
MsgBox ("保存先のドライブレターは存在しません。") & vbCrLf & _
"ドライブが接続されているか？確認してください。" & vbCrLf & _
"処理を中止します。"
Exit Sub
End If

If FrmDir = ToDir Then
MsgBox "送り先と保存先のドライブが同じです。" & vbCrLf & _
"指定ドライブを再確認してください。" & vbCrLf & _
"処理を中止します。"
Exit Sub
End If

Dim FDS As String
'指定ドライブの空き容量(GB)
FDS = Format(objFSO.GetDrive(ToDir).AvailableSpace / 1024 / 1024 / 1024, "#,###")

Dim i As Long
i = 2 'シートの2行目から出力

Call GetFileInfo(FrmDir, i)

'--------------------------------------------- 追加分

Dim lc As Long
Dim CSize As Long

'処理行の総数(空白行を含む)
lc = Cells(Rows.Count, "C").End(xlUp).Row

Application.ScreenUpdating = False

'空白行の削除
For i = lc To 1 Step -1
If Cells(i, "C").Value = 0 Then
Rows(i).Delete
End If
Next i

Application.ScreenUpdating = True

'処理行の総数(空白行を削除後)
lc = Cells(Rows.Count, "C").End(xlUp).Row

'C列をMB単位に換算してE列に書き出す
Dim target
For i = 1 To lc
target = Cells(i, "C").Value
Range("E" & i).Value = target / 1024 / 1024 'MBに換算
Next

'E列の合計を算出
CSize = WorksheetFunction.Sum(Range("E1:E" & lc))

Dim Cize_GB As Long
'合計数を表示（MB & GB)
Cize_GB = CSize / 1024

MsgBox "送る側の総容量 = " & CSize & " MB" & vbCrLf & _
" " & Cize_GB & " GB" & vbCrLf & _
"保存側の空き容量 = " & FDS & " GB"

Set objFSO = Nothing

End Sub

Function GetFileInfo(ByRef strDir As String, ByRef i As Long)
Dim objFSO As FileSystemObject
Dim objFolder As Folder
Dim objFolderSub As Folder
Dim objFile As File

Set objFSO = New FileSystemObject
Set objFolder = objFSO.GetFolder(strDir)

'サブフォルダ一覧
For Each objFolderSub In objFolder.SubFolders
If InStr(objFolderSub.Path, "Documents and Settings") > 0 Then
'
ElseIf Not objFSO.GetFolder(objFolderSub.Path).Attributes And 2 Then
'再帰
Call GetFileInfo(objFolderSub.Path, i)
End If
Next

回答No.12

kkkkkm

> 　FixDayをグローバル変数に戻したらエラーが出なくなりました。

それはよかったです。最初にいらぬお節介を焼いた為に無駄な労力を使わせてしまって申し訳ないです。

> kkkkkmさんの方でうまく処理出来るコードが
> 私の環境では、上手く処理できないようです。

こちらはWindows10,Excel 2013ですが、フォルダからだと異常がないとのことなので、Win10とWin11ではルートにある何かが違うのかもしれませんし、HDDとメモリカードでは差があるのかもしれないですね。

> 何がゼロに成るのでしょうか　？

エクセルは何もないセル(Variant変数も)を対象に数値として計算するとそのセル(Variant変数も)の値は0と認識してくれると思いますのでE1が0になります。

> FixDay = InputBox("何日前からのファイルをコピペしますか　？")

の入力は数値限定にした方が安全だと思います
以下を参照してください。
第100回.InputBoxメソッド（インプットボックス）
https://excel-ubara.com/excelvba1/EXCELVBA400.html

あとはサイズ計算ですね。

お礼

>最初にいらぬお節介を焼いた為に無駄な労力を使わせてしまって申し訳ないです。

色々悩むことで得る事も大きので回り道は気にしていませんし
アドバイスなければ私一人だけでは完工に近づく事はなかったと思います。

アドバイスを受けて
最初のドライブ指定と日付指定を見直しました。
サイズ計算は、GBで表示したいので少し変えました。

関係先のコードのみ下記に書き出しました。

間違った入力をすると全てマクロ終了とするのでイマイチ納得はしていません。

合計を表示する最後の以下ですが、表示が「＝」の位置で上手く揃うようにしたいのですが
試行錯誤で合わせる為に半角のスペースを調整していますが他に何か？スマートな方法はありますか　？

'合計数を表示（MB & GB)

サイズ計算で間違っていますか　？

'--------------------------------------------------------------

'送る側のドライブ指定
FrmDir = Application.InputBox(prompt:="どこから (J)", Title:="送る側のドライブレター", Type:=2)

If (Asc(FrmDir) >= 65 And Asc(FrmDir) <= 90) Or (Asc(FrmDir) >= 97 And Asc(FrmDir) <= 122) Then
'
Else
MsgBox "ドライブレターは、アルファベットで指定してください。"
Exit Sub
End If
FrmDir = FrmDir & ":\"

'保存側のドライブ指定
ToDir = Application.InputBox(prompt:="どこへ　　(E)", Title:="保存側のドライブレター", Type:=2)
If (Asc(ToDir) >= 65 And Asc(ToDir) <= 90) Or (Asc(ToDir) >= 97 And Asc(ToDir) <= 122) Then
'
Else
MsgBox "ドライブレターは、アルファベットで指定してください。"
Exit Sub
End If
ToDir = ToDir & ":\"

'コピペする日付を指定
FixDay = Application.InputBox(prompt:="何日前からのファイルをコピペしますか　？", Title:="日数指定　(Max=14)", Type:=1)

'日付指定の最大をチェック
If Abs(FixDay) > 14 Then
MsgBox "日付指定の最大日数は、１４日以内です。"
Exit Sub
End If

'日付指定はマイナス (プラスで指定したら符号反転）
If FixDay > 0 Then FixDay = -FixDay

Set objFSO = New FileSystemObject

If Not objFSO.FolderExists(FrmDir) Then
MsgBox ("指定のフォルダは存在しません")
Exit Sub
End If

If Not objFSO.FolderExists(ToDir) Then
MsgBox ("指定のフォルダは存在しません")
Exit Sub
End If

'指定ドライブの空き容量(GB)
FDS = Format(objFSO.GetDrive(ToDir).AvailableSpace / 1024 / 1024 / 1024, "#,##")

(途中のコードは省略）

'C列をMB単位に換算してE列に書き出す
Dim target
For i = 1 To lc
target = Cells(i, "C").Value
Range("E" & i).Value = WorksheetFunction.RoundUp(target / 1024 / 1024, 0) 'MBに換算
Next

'E列の合計を算出
For ii = 1 To lc
CSize = WorksheetFunction.Sum(Range("E1:E" & ii))
Next

'合計数を表示（MB & GB)
MsgBox "送る側の総容量 = " & CSize & " MB" & vbCrLf & _
" " & WorksheetFunction.RoundUp(CSize / 1024, 0) & " GB" & vbCrLf & _
"保存側の空き容量 = " & FDS & "GB"

回答No.11

kkkkkm

Range(i).Delete
はエラーになります。
Rows(i).Delete
です。
今の所ここまで実行されていないと思ったので指摘忘れてました。

> 但し、１行目はなぜだか？　E=0　の行が先頭に書き込まれています。

i = 2 'シートの2行目から出力

ですので、C1は何も入っていません。

target = Cells(i, "C").Value
Range("E" & i).Value = WorksheetFunction.RoundUp(target / 1024 / 1024, 0) 'MBに換算

で計算していますから0になります。

最初のコードがエラー無く動いていたのでしたら

On Error Resume Next
だけを変更したコードに、一つずつ機能を追加してどこでエラーになるのか確かめてみるのも手だと思います。

もしかして

Dim FixDay As Integer
グローバル変数にしていますが
Sub フォルダとファイル一覧取得_階層考慮()
のローカル変数にして

あたりが駄目だったのかなという気もしますが…ただ、それだとこちらでもエラーになると思うのですが…
その前に、関係ないとは思いますが一番単純なところで
ByRef FixDay As Integer
ByRef FixDay As Long
にしてみてもいいかも。

補足

アドバイスを受けて
　FixDayをグローバル変数に戻したらエラーが出なくなりました。

私の環境は、Windows11 Pro X64(22H2),Excel 2021 x64

kkkkkmさんの方でうまく処理出来るコードが
私の環境では、上手く処理できないようです。

以下は、直近のアドバイスですが、

＞で計算していますから0になります。

何がゼロに成るのでしょうか　？

（エラーが出なくなってホッとしています。）

以下が修正箇所を含めた最新のコードです。

訂正があればお願いします。

Option Explicit
Dim FixDay As Integer

Sub フォルダとファイル一覧取得_階層考慮()
Dim objFSO As FileSystemObject
Dim FrmDir As String, ToDir As String
Dim strDir As String
Dim i As Long
Dim FDS As String

FrmDir = InputBox("どこから (J)", "送る側のドライブレター")
FrmDir = FrmDir & ":\"
ToDir = InputBox("どこへ　　(E)", "保存側のドライブレター")
ToDir = ToDir & ":\"

FixDay = InputBox("何日前からのファイルをコピペしますか　？")
'日付指定はマイナス (プラスで指定したら符号反転）
If FixDay > 0 Then FixDay = -FixDay

Set objFSO = New FileSystemObject

If Not objFSO.FolderExists(FrmDir) Then
MsgBox ("指定のフォルダは存在しません")
Exit Sub
End If

If Not objFSO.FolderExists(ToDir) Then
MsgBox ("指定のフォルダは存在しません")
Exit Sub
End If

'指定ドライブの空き容量(MB)
FDS = Format(objFSO.GetDrive(ToDir).AvailableSpace / 1024 / 1024, "#,##")

i = 2 'シートの2行目から出力

Call GetFileInfo(FrmDir, i)

'--------------------------------------------- 追加分

Dim lc As Long, ii As Long
Dim CSize As Long

'処理行の総数(空白行を含む)
lc = Cells(Rows.Count, "C").End(xlUp).Row

Application.ScreenUpdating = False

'空白行の削除
For i = lc To 1 Step -1
If Cells(i, "C").Value = 0 Then
Rows(i).Delete
End If
Next i

Application.ScreenUpdating = True

'処理行の総数(空白行を削除後)
lc = Cells(Rows.Count, "C").End(xlUp).Row

'C列をMB単位に換算してE列に書き出す
Dim target
For i = 1 To lc
target = Cells(i, "C").Value
Range("E" & i).Value = WorksheetFunction.RoundUp(target / 1024 / 1024, 0) 'MBに換算
Next

'E列の合計を算出
For ii = 1 To lc
CSize = WorksheetFunction.Sum(Range("E1:E" & ii))
Next

'合計数を表示（MB & GB)
MsgBox "送る側の総容量 = " & CSize & " MB" & vbCrLf & _
" " & WorksheetFunction.RoundUp(CSize / 1024, 0) & " GB" & vbCrLf & _
"空き容量 = " & FDS

Set objFSO = Nothing

End Sub

Function GetFileInfo(ByRef strDir As String, ByRef i As Long)
Dim objFSO As FileSystemObject
Dim objFolder As Folder
Dim objFolderSub As Folder
Dim objFile As File

Set objFSO = New FileSystemObject
Set objFolder = objFSO.GetFolder(strDir)

'サブフォルダ一覧
For Each objFolderSub In objFolder.SubFolders
If InStr(objFolderSub.Path, "Documents and Settings") > 0 Then
'
ElseIf Not objFSO.GetFolder(objFolderSub.Path).Attributes And 2 Then
'再帰
Call GetFileInfo(objFolderSub.Path, i)
End If
Next

'ファイル一覧
For Each objFile In objFolder.Files
With objFile
If .DateLastModified >= DateAdd("D", FixDay, Date) Then
Cells(i, 2) = .Name
Cells(i, 3) = .Size
Cells(i, 4) = .DateLastModified
i = i + 1
End If
End With
Next
Set objFSO = Nothing
Set objFolder = Nothing
Set objFolderSub = Nothing

End Function

回答No.10

kkkkkm

> あまりに深いフォルダ階層を取得しようとすると「スタック領域が不足しています」エラーが発生がある

そうですね。ただ、3階層しかなくて、しかも出たのがすぐで一番上のフォルダですし変ですね…。
ちなみに、こちらでは8階層まであるフォルダがありましたがエラーにはなりませんでした。
対象はメモリカードです。

Eドライブで一度試してみてもいいかもしれません。
もしくは「J:\あああ」からはじめてみるとか。

お礼

追加情報です。

>Eドライブで一度試してみてもいいかもしれません。

E：ドライブでも同じ箇所でエラーがでました。

>もしくは「J:\あああ」からはじめてみるとか。

以下のようにで決め打ちして試してみましたが
同じ状況です。

' FrmDir = InputBox("どこから (J)", "送る側のドライブレター")
' FrmDir = FrmDir & ":\"

FrmDir = "J:\あああ\"

ToDir = InputBox("どこへ　　(E)", "保存側のドライブレター")
ToDir = ToDir & ":\"

そこで「J:\あああ\test」のようにテスト用のフォルダーを作成して
その中に３個のタイムスタンプが本日(1/17)のファイルを配置して試してみました。

FrmDir = "J:\あああ\test\"

'空白行の削除　の下記のコードでエラーが出るので
とりあえず「空白行の削除」のコード全体をコメントアウトしました。
Range(i).Delete

結果、エラー無く終了しました。
但し、１行目はなぜだか？　E=0　の行が先頭に書き込まれています。
（多分、これが原因で「空白行の削除」でエラーが出たのだと思います。）

|[A]|[B] |[C] |[D] |[E]
[1]| | | | | 0
[2]| |aaa.mp |1166428599|2023/1/17 8:47|1139090.5
[3]| |bbb.mp4 |2725443753|2023/1/17 8:42|2661566.2
[4]| |ccc.mp4 |2699738895|2023/1/17 8:45|2636463.8

同じJ:\を対象に
最初の頃は完走していたコードが色々改良すると
「スタック領域が不足」で完走しなくなっています。

現状、全く打つ手なしです。

最初の頃のコードと考えは変わっていないのに不思議です。

補足

あ、対象ファイルがmp4(mp)となっていますが
用意できるファイルがたまたまｍｐ４だっただけです。

mpと有るのは、mp4の間違いでミス記載です。

回答No.9

kkkkkm

> あまりの遅さにctrl+Breakでマクロを強制終了しました。

On Error Resume Nextだとフォルダやファイルが多い(アクセスできないなどのエラーがある場合かも)と終わらない(終わるまで待てない)感じですね。

前回と同じ 隠しフォルダを除く設定

For Each objFolderSub In objFolder.SubFolders
If InStr(objFolderSub.Path, "Documents and Settings") > 0 Then
'
ElseIf Not objFSO.GetFolder(objFolderSub.Path).Attributes And 2 Then
' '再帰
Call GetFileInfo(objFolderSub.Path, i, FixDay)
End If
Next

で試してみてください。

検査対象
フォルダ数 12000位、ファイル数 50000位 だと1分くらいで終わりました。
こちらのPCは古いので上記でも時間がかかっていると思います。

これで解決しない場合は、notnotさんに回答をもらっている現状の問題を先に解決してはいかがでしょう。

お礼

kkkkkmさん、アドバイスを受けてコード改変しました。

（On Error Resume Next　で逃げるのは駄目だと言う事ですね。）

試してみると
今度は、すぐに以下のコードで実行エラーが発生しました。

スタック領域が不足しています。

Call GetFileInfo(FrmDir, i, FixDay)

調べてみると
再帰プロシージャでは、スタック領域に記憶される"呼び出し履歴"が、どうしても増大して
あまりに深いフォルダ階層を取得しようとすると「スタック領域が不足しています」エラーが発生があるとの事でした。

ターゲットのドライブでは以下のような３階層が最大です。
他にも複数同じ３階層のフォルダーが存在します

J:\あああ\いいい\ううう.mp3

エラー時のローカルウインドウを見ると
i=2
ObjFolderSub Name は、最初のJ:\あああ でした。

情報不足ですが何か分かりますか　？
（ローカルウインドウで他に開示すべき事項あれば追加で報告いたしますので教えてください。）

'------　以下の部分を修正　------------------------

'サブフォルダ一覧
'On Error Resume Next
For Each objFolderSub In objFolder.SubFolders
If InStr(objFolderSub.Path, "Documents and Settings") > 0 Then
'
ElseIf Not objFSO.GetFolder(objFolderSub.Path).Attributes And 2 Then
'再帰
Call GetFileInfo(FrmDir, i, FixDay)
End If
Next

'-------------------------------------------