• ベストアンサー
  • 困ってます

どれくらい容量を増やせば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
  • ベストアンサー率63% (1350/2133)

> 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 "日付指定の最大日数は、14日以内です。" & 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 に訂正します。 最後のyが抜けていました。

その他の回答 (18)

  • 回答No.18
  • kkkkkm
  • ベストアンサー率63% (1350/2133)

> 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 "日付指定の最大日数は、14日以内です。" & 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
  • ベストアンサー率63% (1350/2133)

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

共感・感謝の気持ちを伝えよう!

  • 回答No.16
  • kkkkkm
  • ベストアンサー率63% (1350/2133)

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

共感・感謝の気持ちを伝えよう!

質問者からのお礼

kkkkkmさん、コードの見直しで何度もアドバイス頂きありがとうございます。 確かに、散らばっていたinputの判断は 一箇所にしたほうが判りやすく 3つInputしてその後に「送る側が存在しない」とか言われたら先に言ってよとなりますね。 MSGBOXの件ですが、確かの@より0の方がキレイに揃いますが 頭に0が並ぶのは普通目にしないので@の方を採用したいと思います。 又、MBの数値は3桁区切りのほうが好みなので書式を変更しました。 VBなどでは、数値を3けた区切りの文字列に変換する事が出来るそうですが VBAで調べても参考記事がヒットしないので普通に「#,###」で数値を3桁区切りに変更しました。 (表示されるmsgboxの表示を見ると  わざわざ数値を3けた区切りの文字列に変換する必要も無さそうに思えます。) https://imgur.com/ZTbdGbj 個人的には、長々とご指導願いましたが 完成かな?と思っていたのですが、 以下のコードでまた煮詰まりました。 現在のコードでは、 inputboxでキャンセルをクリックした場合とゼロを入力し場合を区別したいのですが キャンセルを押してもゼロが入力されたと解釈されています。 StrPtr(FixDay) = で ゼロ(0)を指定しているので当然でしょうが ここはどう変えれば良いでしょうか ? なお、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 "日付指定の最大日数は、14日以内です。" & 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-Za-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-Za-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
  • ベストアンサー率63% (1350/2133)

画像添付し忘れました。

共感・感謝の気持ちを伝えよう!

  • 回答No.14
  • kkkkkm
  • ベストアンサー率63% (1350/2133)

ループの中で調べるのは以下のような感じにしたらどうかなと思ってました。 正しいデータを入れるかキャンセルするまで入力を促します。 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-Za-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
  • ベストアンサー率63% (1350/2133)

> 間違った入力をすると全てマクロ終了とするのでイマイチ納得はしていません。 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-Za-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-Za-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 "日付指定の最大日数は、14日以内です。" 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
  • ベストアンサー率63% (1350/2133)

>  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 "日付指定の最大日数は、14日以内です。" 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
  • ベストアンサー率63% (1350/2133)

Range(i).Delete はエラーになります。 Rows(i).Delete です。 今の所ここまで実行されていないと思ったので指摘忘れてました。 > 但し、1行目はなぜだか? 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
  • ベストアンサー率63% (1350/2133)

> あまりに深いフォルダ階層を取得しようとすると「スタック領域が不足しています」エラーが発生がある そうですね。ただ、3階層しかなくて、しかも出たのがすぐで一番上のフォルダですし変ですね…。 ちなみに、こちらでは8階層まであるフォルダがありましたがエラーにはなりませんでした。 対象はメモリカードです。 Eドライブで一度試してみてもいいかもしれません。 もしくは「J:\あああ」からはじめてみるとか。

共感・感謝の気持ちを伝えよう!

質問者からのお礼

追加情報です。 >Eドライブで一度試してみてもいいかもしれません。 E:ドライブでも同じ箇所でエラーがでました。 >もしくは「J:\あああ」からはじめてみるとか。 以下のようにで決め打ちして試してみましたが 同じ状況です。 ' FrmDir = InputBox("どこから (J)", "送る側のドライブレター") ' FrmDir = FrmDir & ":\" FrmDir = "J:\あああ\" ToDir = InputBox("どこへ  (E)", "保存側のドライブレター") ToDir = ToDir & ":\" そこで「J:\あああ\test」のようにテスト用のフォルダーを作成して その中に3個のタイムスタンプが本日(1/17)のファイルを配置して試してみました。 FrmDir = "J:\あああ\test\" '空白行の削除 の下記のコードでエラーが出るので とりあえず「空白行の削除」のコード全体をコメントアウトしました。 Range(i).Delete 結果、エラー無く終了しました。 但し、1行目はなぜだか? 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)となっていますが 用意できるファイルがたまたまmp4だっただけです。 mpと有るのは、mp4の間違いでミス記載です。

  • 回答No.9
  • kkkkkm
  • ベストアンサー率63% (1350/2133)

> あまりの遅さに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) 調べてみると 再帰プロシージャでは、スタック領域に記憶される"呼び出し履歴"が、どうしても増大して あまりに深いフォルダ階層を取得しようとすると「スタック領域が不足しています」エラーが発生があるとの事でした。 ターゲットのドライブでは以下のような3階層が最大です。 他にも複数同じ3階層のフォルダーが存在します 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 '-------------------------------------------

関連するQ&A

  • ドライブ直下の半透明のファイル「Attachment」これは何でしょうか?0バイトです。

    何日か前に新たにつくった、データ用のドライブ(パーティション)です。 別なドライブからコピーしてしまったのかもしれません。 他のドライブの直下には半透明の$RECYCLE.BINフォルダ・RECYCLERフォルダ・System Volume Informationフォルダがありますが、Attachmentというのはありません。 このドライブの直下には、$RECYCLE.BINフォルダがありません。事情は不明です。 システムファイルをあらわす、茶色の歯車みたいなのと紙のアイコン、になっています。 プロパティでは、 ファイルの種類:構成設定 拡張子はよく分かりません。 サイズ:0バイト ディスク上ノサイズ:0バイト WindowsXP Pro SP3

  • 分からないフォルダ

    何度かリカバリーを行った結果 Dドライブに『System Volume Information』『System Volume Information2』 『$RECYCLE.BIN』というフォルダーが表示されているのですが、このままほっといても問題ないでしょか?それと知らない間に『found.000』『found.001』という様なフォルダができてしまっているのですが、 これはいったいなんでしょうか? お分かりの方がいらっしゃいましたら回答の程よろしくお願いします。

  • Dドライブの領域の容量が不足しています。

    パソコンのDドライブの領域の容量が不足していますとメッセージが度々表示されます。 ドライブの中身は RECYCLE.BIN PC System Volume Infomationです。 自動バックアップは外付けのハードディスクドライブに設定しています。 Dドライブの中の何を削除すればいいのでしょうか? 以上、よろしくお願い致します

  • WIN8 外付HDD内ファイルが削除できない

    (1)外付HDD内のバックアップ(システムイメージ)ファイルを不注意にも削除してしましました。 (2)再度はバックアップはできませんでした。 ➂ネットをググって隠しファイルを表示させて、所有権の設定やアクセス権の設定をしました。   正しい設定が出来たかどうかはわかりません。 (4)$RECYCLE.BINは削除できました(消えました) (五)System Volume Informationは削除できません。 ➅System Volume Informationをwクリックするとtracking.logが表示されました。 ➆元に戻ると、$RECYCLE.BINとSystem Volume Informationの2個のファイル表示されました。 (8)何度やってもイタチごっこの様な繰り返しです ➈完全フォーマットを行っても消えません (10)もしかしたら、所有権の設定やアクセス権の設定が不完全かもしれません。 (11)このままでは、このHDDはバックアップ(システムイメージ)用には使用できないということでしょうか どなたか、初心者でも出来る手順を細かく教えてください。お願いします。

  • Dドライブが削除出来ない

    QNo.6883587の続きになります。よろしくお願いします。 NECのVISTAでハードディスクのパーティションを変更してCドライブの容量を拡張したく、 Dドライブを圧縮して未割り当てを作りましたが、それではCドライブはボリュームの拡張出来ない事がわかり元に戻しました。 で、改めてDドライブの削除をしようとしているのですが、Dが空になりません。 Dに設定している仮想メモリとして設定したときに出来るページファイルがあると削除出来ないとネットで調べてわかったのでDに設定している仮想メモリをCに移しました。 それなのにpagefile.sysと中身が空の$RECYCLE.BIN、System Volume Information、 私の名前のフォルダ、が消しても消しても出てきてしまいます。 どうしたら良いのでしょう? 例えば何かソフトを使って強制的に削除出来るのでしょうか?

  • ドライブの容量について

    WINNT4.0でCADを使用してます。 HDDの全容量は、14ギガあるのですが、Cドライブは2ギガで Eドライブは12ギガになってます。最初は、CドライブでCADを起動してたのですが、容量不足(760メガ)のため、Eドライブに移動しました。 でも、TEMPファイルなどが、Cドライブに入っていくため、すぐに容量不足になります。TEMPファイルなどをすべてEドライブに入るようにするには、どのようにしたらいいでしょうか?また、現在の状態を保ったまま、Cドライブを増やすには、どのようにしたらいいでしょうか?パーテーションマジックもNTの場合 どのようにしたらいいのかわかりません。みなさんの所では、どのようにしているのか教えていただけないでしょうか?宜しくお願いします。

  • ハードディスクの不明な使用領域

    OS:WindowsXP_Home HDDをC.D.Eに分割し、D.Eにはデータを保存しています。 ボリューム(D)の全容量10GBです、隠しフォルダ、ファイルを含むすべてをボリューム(E)に移動し、保護されたオペレーティングシステムを表示すると[$RECYCLE.BIN],[RECYCLER],[System Volume Information] が存在します、各サイズは129バイト、420MB、空ですが、プロパティを開くと使用領域が1.42GBになっています、この誤差約1GBはなんなのでしょうか? ボリューム(D)をフォーマットすることが出来ますか、また、フォーマットした場合、保護されたオペレーティングシステムが消去され、やはりなんらかの不具合が起こりますか?

  • 見知らぬアプリが沢山出現する

    Fドライブ(外付けHDD)のsystem volume informationのフォルダの中に見知らぬexeファイルが沢山あります。名称はA2980.exeとかこんな調子ですが、アイコンは見慣れたもので現在私が使用してるアプリのアイコンなんです。全部で4Gあるようです。 あとCドライブのtempフォルダにいつもwcompute.exeとかzcompute.exeとか現れてアンチウィルスが毎回削除するのですが再び現れてしまいます。 どうすればいいでしょうか? 多分ウィルスに侵されてると思いますが、完全駆除したいです。

  • Dドライブがいっぱいになって困っています。

    いつもお世話になります。 PC起動時に 「ディスク領域不足:Dドライブの空き容量がないので確認してください」 という旨のメッセージが出ます。 確認してみると、Dドライブの空き領域はほとんどありません。 普段、ドキュメントや画像データなど、Dドライブには 保存しないようにしています。 1月にも同じメッセージが出て そのときには 古いバックアップメモリ(復元ポイントととして使われるもの) などを削除することで正常化しましたが、たった2ヶ月でまた満杯… プロパティ→システムのクリーンアップで見てみましたが、 削除できるようなものはなく、どうすればいいのか困っています。 使用しているパソコンは DESKPOWER FMVFG90DBY 2010年5月から使用しています。 ちなみにDドライブを開いてみたところ 現在格納されているのは以下のものです。 ●$RECYCLE.BIN ●Fujitsu ●××××-PC (××××は私の名前。) ●System.Volume Infomation ●WindowsImageBackup ●MediaID.bin ●MW7Up 解決方法をご存知の方、 または解決の糸口について、お心あたりのある方、 ぜひ、教えてください。よろしくお願いします!

  • ローカルディスク(D)内のフォルダについて

    Window7を去年(2013年)の11月ころから使っていますが (購入は銅線から光回線を導入した2012年8月です) エクスプローラでDドライブを開くと ローカルディスク(D)  $RECYCLE.BIN ← この下(中)に「ごみ箱」フォルダが存在する。  MyDoc ← このフォルダは自分で作成した。  System Volume Information  マイフォト の4フォルダが見えます。 それで質問です。 (1)$RECYCLE.BIN フォルダは 「ごみ箱」とどう違うのですか? またフォルダ名の先頭1文字目の”$”はどんな意味があるのですか? (2)System Volume Informationフォルダは、何なのですか?   つい最近までアクセスができなかったのですが   プロパティのセキュリティを変更してアクセスできるようになりました。   中にはtracking.logというのが入っていました。   これもなんなのですか? ※OKWaveより補足:「富士通FMV」についての質問です。