ExcelのVBAで教えてください。

質問

教えて下さい。

(1)shellでフォルダ選択の画面を開き、選んだフォルダの名前を
指定したセル（B4）に入れるマクロを教えて下さい。
ファイル名なら入れ方が分かるのですが、フォルダ名のやり方が
いまいち分かりません。

(2)上記の(1)で選ぶファルダ名は、20140903235937_JIK　のように
日付と時間とアンダーバーとアルファベットで構成されています。

例えば(1)のマクロでB4にファルダ名を入力し、同じく(1)のマクロでG4に
フォルダ名を入力した時、B4のファルダ名の時間からG4のフォルダ名の
時間が3時間以上経っているかを確認し、3時間以上ならJ4セルにOKと表示。
3時間未満なら同じくJ4セルにNG表示。さらにNGの場合はK4セルに3時間までの
残り時間を表示したいです。

また別のお話で、G20にも上記と同じようにフォルダ名を入れたいのですが
G20の場合は少し複雑で、shellでフォルダを選択したとき、その選んだフォルダから
11個前までのフォルダを自動で選んで、セルR20からR30にその11個のデータを表示したい。
ちなみにG20にはshellで選んだのフォルダ名を表示したい。
例えば下記のように

20130322134700_JIK
20130322134855_JIK
20130322135021_JIK
20130322135146_JIK
20130322135312_JIK
20130322135438_JIK
20130322135603_JIK
20130322135729_JIK
20130322135854_JIK
20130322140020_JIK
20130322140145_JIK
20130322140311_JIK

shellでこようなフォルダが並んでいる場合、一番最後の20130322140311_JIKを選んだら
それを含めた11個前のフォルダ、20130322135021_JIKまでを
R20からR30に表示したい。並び順は上から（R20）古い時間で一番下（R30）が最新の時間になるようにです。
G20にはshellで選んだ20130322140311_JIKを表示する。
さらにの11個の中の一番古い時間（セルR20）の時間とセルB20の時間を比べて
R20の時間がB20の時間から3時間以上経っているか。R20がG4の時間から24時間以上経っているかを確認したい。

確認方法は(2)と同じ。ただし確認項目が1つ増える。
3時間の確認はJ20に。3時間未満の時はK20に残りの時間を表示。
24時間の確認はL20に。24時間未満の時はM20に残りの時間を表示。

以上が、今回の行いたいことです。

今回はネットで探しても似たようなマクロがなかった為、サンプルマクロがありません。
申し訳御座いません。

いつもいつもわかりずらいマクロ、表現、説明でもすみませんが
御指導の程、宜しくお願いします。

回答No.3

kagakusuki · ベストアンサー

>例えば【V:\新３係（ＦＩＡ・ｉＰｏｔ）\生産進捗表】このような階層で
(中略)
>フォルダは全てこのような20130322140311_JIKのような形式の型になります。

　それでしたら次の様なマクロで宜しいでしょうか?

Sub QNo9002836_ExcelのVBAで教えてください3()
Dim CriteriaName(2), myBox, CriteriaDT(2) As Double, myFolder As Object, _
i As Long, myFolderName As String, NameEnd As String, ParentPath As String, _
OutputCell(5) As String, myIsDate(2) As Boolean, OutputRange As Range

OutputCell(0) = "B4" '1つ目のフォルダー名を入力するセルのセル番号
OutputCell(1) = "G4" '2つ目のフォルダー名を入力するセルのセル番号
OutputCell(2) = "G20" '3つ目のフォルダー名を入力するセルのセル番号
OutputCell(3) = "J4" '3つ目のフォルダー名の表わす日時が2つ目のフォルダー名の表わす日時から3時間以上経過しているか否かを表示するセルのセル番号
OutputCell(4) = "J20" '11個前のフォルダー名の表わす日時が1つ目のフォルダー名の表わす日時から3時間以上経過しているか否かを表示するセルのセル番号
OutputCell(5) = "L20" '11個前のフォルダー名の表わす日時が2つ目のフォルダー名の表わす日時から24時間以上経過しているか否かを表示するセルのセル番号

NameEnd = "_JIK" '処理の対象とするフォルダー名から日時を表す部分を除いた字列
Set OutputRange = Range("R20:R30") '3つ目のフォルダー名～11個前のフォルダー名を入力するセル範囲

ParentPath = "C:\Users\"
ParentPath = _
"C:\Users\Shinomori Masahiro\Documents\投稿等\OKWave\QNo.9002836 ExcelのVBAで教えてください。"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 0 To 2
label1:
Set myFolder = CreateObject("Shell.Application"). _
BrowseForFolder(0, i + 1 & "つ目のフォルダーを選択して下さい", _
785, ParentPath & "")
If myFolder Is Nothing Then
myBox = MsgBox(i + 1 & "つ目のフォルダーが選択されていません。" _
& vbCrLf & "フォルダーの選択をやり直しますか?" & vbCrLf & vbCrLf _
& "[はい]:フォルダーの選択をやり直します" & vbCrLf _
& "[いいえ]:処理を中止してマクロを終了します", _
vbYesNo + vbExclamation, "フォルダー未選択")
If myBox = vbNo Then GoTo sub_Exit
Else
With myFolder.Items.Item
CriteriaName(i) = .Name
myIsDate(i) = Left(CriteriaName(i), 14) & NameEnd = CriteriaName(i) _
And IsDate(Format(Val(CriteriaName(i)), "0000-00-00 00:00:00"))
If myIsDate(i) Then
CriteriaDT(i) = Val(CriteriaName(i))
Else
myBox = MsgBox( _
"選択したフォルダーの名称はこのマクロで処理の対象としている形式の名称になっておりません。" _
& vbCrLf & "このマクロで処理の対象としているのは" & vbCrLf & vbCrLf _
& "yyyymmddhhmmss" & NameEnd & vbCrLf _
& "(4桁の西暦年&2桁の月&2桁の日&2桁の時刻&2桁の分&2桁の秒" & NameEnd & ")" _
& vbCrLf & vbCrLf & "という形式になっているフォルダー名だけです。" _
& vbCrLf & "フォルダーの選択をやり直しますか?" & vbCrLf & vbCrLf _
& "[はい]:フォルダーの選択をやり直します" & vbCrLf _
& "[いいえ]:このまま処理を続行しますが、日時の比較は行いません。" & vbCrLf _
& "[キャンセル]:処理を中止してマクロを終了します", _
vbYesNoCancel + vbExclamation + vbDefaultButton2, "無効な選択")
Select Case myBox
Case vbCancel
GoTo sub_Exit
Case vbNo
Case Else
GoTo label1
End Select
End If
Range(OutputCell(i)).Value = CriteriaName(i)
ParentPath = Left(.Path, InStrRev(.Path, "\") - 1)
End With
End If
Set myFolder = Nothing
Next i

With Range(OutputCell(3))
.Resize(1, 2).Value = "-"
If myIsDate(0) And myIsDate(1) Then
If CriteriaDT(1) - CriteriaDT(0) < 30000 Then
.Value = "NG"
With .Offset(, 1)
.NumberFormatLocal = "[h]:mm:ss"
.Value = CDate(Format(CriteriaDT(0), "0000-00-00 00:00:00")) _
+ TimeSerial(3, 0, 0) - CDate(Format(CriteriaDT(1), "0000-00-00 00:00:00"))
End With
Else
.Value = "OK"
End If
End If
End With

With OutputRange
.ClearContents
If myIsDate(2) Then
myFolderName = Dir(ParentPath & "\" & String(14, "?") & NameEnd, vbDirectory)
i = -1
Do Until myFolderName = "" Or WorksheetFunction.CountIf(.Offset(), CriteriaName(2)) > 0
If IsDate(Format(Val(myFolderName), "0000-00-00 00:00:00")) Then
If i < .Rows.Count - 1 Then
i = i + 1
Else
With .Resize(i, 1)
.Value = .Offset(1).Value
End With
End If
.Resize(1, 1).Offset(i).Value = myFolderName
End If
myFolderName = Dir
Loop
myFolderName = .Resize(1, 1).Value
If myFolderName = "" Then
MsgBox "処理の対象となるフォルダーが見つかりません。" & vbCrLf _
& "マクロを終了します", vbExclamation, "該当フォルダー無し"
GoTo labelE
End If
End If
End With

With Range(OutputCell(4))
.Resize(1, 2).Value = "-"
If myIsDate(0) And OutputRange.Resize(1, 1).Value <> "" Then
If Val(myFolderName) - CriteriaDT(0) < 30000 Then
.Value = "NG"
With .Offset(, 1)
.NumberFormatLocal = "[h]:mm:ss"
.Value = CDate(Format(CriteriaDT(0), "0000-00-00 00:00:00")) _
+ TimeSerial(3, 0, 0) - CDate(Format(Val(myFolderName), "0000-00-00 00:00:00"))
End With
Else
.Value = "OK"
End If
End If
End With

※まだ途中なのですが、回答欄に入力可能な文字数制限を超えてしまうため、残りは又後で投稿致します。

回答No.5

kagakusuki

>選んだフォルダから11個前までフォルダを選択してR20からR30に入力するマクロはどの部分になるのでしょうか？

　次の部分になります。

With OutputRange
.ClearContents
If myIsDate(2) Then
myFolderName = Dir(ParentPath & "\" & String(14, "?") & NameEnd, vbDirectory)
i = -1
Do Until myFolderName = "" Or WorksheetFunction.CountIf(.Offset(), CriteriaName(2)) > 0
If IsDate(Format(Val(myFolderName), "0000-00-00 00:00:00")) Then
If i < .Rows.Count - 1 Then
i = i + 1
Else
With .Resize(i, 1)
.Value = .Offset(1).Value
End With
End If
.Resize(1, 1).Offset(i).Value = myFolderName
End If
myFolderName = Dir
Loop
myFolderName = .Resize(1, 1).Value
If myFolderName = "" Then
MsgBox "処理の対象となるフォルダーが見つかりません。" & vbCrLf _
& "マクロを終了します", vbExclamation, "該当フォルダー無し"
GoTo labelE
End If
End If
End With

　これは、指定されたフォルダー内にある「『14文字の文字列』+『_JIK』」の形式となっているフォルダー名のみを、Dir関数を使って先頭から順番に１つずつ変数myFolderNameに上書きする形で格納して行き、その変数myFolderNameに格納された文字列データが、日付に変換可能なものであった場合にのみ、R20以下に書き込んで行き、R30まで書き込まれる様になった場合には、R21:R30に書き込まれている値をR20:R29に上書きしてから、新たなフォルダー名をR30に書き込むという処理を行っています。(他にもその処理を開始する前にR20:R30に先に入力されていた値を消去したり、書き込むべきフォルダー名が存在しなかった場合にはその旨を報告する表示を出す、などといった処理も行う部分も含まれています)
　尚、上記の箇所で使われている変数に格納されている値の中には、上記の箇所よりも前の所で格納した値を利用している箇所も多々御座いますので、上記の箇所のみを単独で抜き出して使おうとしてもエラーとなってしまう筈ですので注意して管さとい。

お礼

お礼が遅くなりすみません。

ありがとうございます。
このように取り出していたのですね。

と言ってもまだまだ勉強不足で半分も理解出来ていません。
今後もご質問させて頂く事が多々ありますが、その時はまたよろしくお願いします。

マクロの御回答をベストアンサーとさせて頂きます。

本当にありがとうございました。

回答No.4

kagakusuki

回答No.3の続きです。

With Range(OutputCell(5))
.Resize(1, 2).Value = "-"
If myIsDate(1) And OutputRange.Resize(1, 1).Value <> "" Then
If Val(myFolderName) - CriteriaDT(1) < 1000000 Then
.Value = "NG"
With .Offset(, 1)
.NumberFormatLocal = "[h]:mm:ss"
.Value = CDate(Format(CriteriaDT(1), "0000-00-00 00:00:00")) _
+ 1 - CDate(Format(Val(myFolderName), "0000-00-00 00:00:00"))
End With
Else
.Value = "OK"
End If
End If
End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "処理が完了しました。", vbInformation, "完了"

GoTo labelE
sub_Exit:
MsgBox "処理を中止してマクロを終了します", vbInformation, "マクロの終了"
labelE:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

　以上です。

補足

素晴らしすぎる回答ありがとうございます。

期待を超えすぎててびっくりしております。

ちなみに今後のご参考の為に、教えて頂きたいのですが
選んだフォルダから11個前までフォルダを選択してR20からR30に入力するマクロは
どの部分になるのでしょうか？

見たこともないマクロでいい意味で理解ができません。
すみませんが教えて下さい。

回答No.2

kagakusuki

>しかしながら、NGの場合3時間までの残り時間の表示がなかったですが、やはり
残り時間の表示は難しいでしょうか？

　失礼致しました。

>さらにNGの場合はK4セルに3時間までの
残り時間を表示したいです。

という記述があるのを見落としておりました。

Sub QNo9002836_ExcelのVBAで教えてください2_改()
Dim CriteriaName(1), myBox, CriteriaDT(1) As Double, myFolder As Object, _
NameEnd As String, ParentPath As String, i As Long, _
OutputCell(2) As String, myIsDate As Boolean

OutputCell(0) = "B4" '1つ目のフォルダー名を入力するセルのセル番号
OutputCell(1) = "G4" '2つ目のフォルダー名を入力するセルのセル番号
OutputCell(2) = "J4" '3つ目のフォルダー名の表わす日時が2つ目のフォルダー名の表わす日時から3時間以上経過しているか否かを表示するセルのセル番号
NameEnd = "_JIK" '処理の対象とするフォルダー名から日時を表す部分を除いた字列

ParentPath = "C:\Users\"
ParentPath = "C:\Users\Shinomori Masahiro\Documents\投稿等\OKWave\QNo.9002836 ExcelのVBAで教えてください。"
myIsDate = True
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 0 To 1
label1:
Set myFolder = CreateObject("Shell.Application"). _
BrowseForFolder(0, i + 1 & "つ目のフォルダーを選択して下さい", _
785, ParentPath & "")
If myFolder Is Nothing Then
myBox = MsgBox(i + 1 & "つ目のフォルダーが選択されていません。" _
& vbCrLf & "フォルダーの選択をやり直しますか?" & vbCrLf & vbCrLf _
& "[はい]:フォルダーの選択をやり直します" & vbCrLf _
& "[いいえ]:処理を中止してマクロを終了します", _
vbYesNo + vbExclamation, "フォルダー未選択")
If myBox = vbNo Then GoTo sub_Exit
Else
With myFolder.Items.Item
CriteriaName(i) = .Name
If Left(CriteriaName(i), 14) & NameEnd = CriteriaName(i) And _
IsDate(Format(Val(CriteriaName(i)), "0000-00-00 00:00:00")) Then
CriteriaDT(i) = Val(CriteriaName(i))
Else
myBox = MsgBox( _
"選択したフォルダーの名称はこのマクロで処理の対象としている形式の名称になっておりません。" _
& vbCrLf & "このマクロで処理の対象としているのは" & vbCrLf & vbCrLf _
& "yyyymmddhhmmss" & NameEnd & vbCrLf _
& "(4桁の西暦年&2桁の月&2桁の日&2桁の時刻&2桁の分&2桁の秒" & NameEnd & ")" _
& vbCrLf & vbCrLf & "という形式になっているフォルダー名だけです。" _
& vbCrLf & "フォルダーの選択をやり直しますか?" & vbCrLf & vbCrLf _
& "[はい]:フォルダーの選択をやり直します" & vbCrLf _
& "[いいえ]:このまま処理を続行しますが、日時の比較は行いません。" & vbCrLf _
& "[キャンセル]:処理を中止してマクロを終了します", _
vbYesNoCancel + vbExclamation + vbDefaultButton2, "無効な選択")
Select Case myBox
Case vbCancel
GoTo sub_Exit
Case vbNo
myIsDate = False
Case Else
GoTo label1
End Select
End If
Range(OutputCell(i)).Value = CriteriaName(i)
ParentPath = Left(.Path, InStrRev(.Path, "\") - 1)
End With
End If
Set myFolder = Nothing
Next i

With Range(OutputCell(2))
.Resize(1, 2).Value = "-"
If myIsDate Then
If CriteriaDT(1) - CriteriaDT(0) < 30000 Then
.Value = "NG"
With .Offset(, 1)
.NumberFormatLocal = "[h]:mm:ss"
.Value = CDate(Format(CriteriaDT(0), "0000-00-00 00:00:00")) _
+ TimeSerial(3, 0, 0) - CDate(Format(CriteriaDT(1), "0000-00-00 00:00:00"))
End With
Else
.Value = "OK"
End If
End If
End With

GoTo labelE
sub_Exit:
MsgBox "処理を中止してマクロを終了します", vbInformation, "マクロの終了"
labelE:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

回答No.1

kagakusuki

>(1)shellでフォルダ選択の画面を開き、選んだフォルダの名前を指定したセル（B4）に入れるマクロを教えて下さい。

　何故、shellを使う方法しか使ってはいけないのか解りませんが、取り敢えず次のようなマクロでは如何でしょうか?

Sub QNo9002836_ExcelのVBAで教えてください。1()
Dim myFolder
Set myFolder = CreateObject("Shell.Application").BrowseForFolder(0, "フォルダを選んでください", 11, "C:\Users")
If Not myFolder Is Nothing Then
Range("B4").Value = myFolder.Items.Item.Name
End If
Set myFolder = Nothing
End Sub

>(2)上記の(1)で選ぶファルダ名は、20140903235937_JIK　のように日付と時間とアンダーバーとアルファベットで構成されています。

>例えば(1)のマクロでB4にファルダ名を入力し、同じく(1)のマクロでG4に フォルダ名を入力した時、B4のファルダ名の時間からG4のフォルダ名の時間が3時間以上経っているかを確認し、3時間以上ならJ4セルにOKと表示。
>3時間未満なら同じくJ4セルにNG表示。さらにNGの場合はK4セルに3時間までの
残り時間を表示したいです。

　(1)のマクロはB4にファルダ名を書き込むマクロですので、

>(1)のマクロでG4に フォルダ名を入力

という事は出来ません。
　尚、(1)のマクロとは無関係に、もしB4セルとG4セルに最初からその様な形式のフォルダー名が入力されているという条件でしたら、次の様なマクロになります。

Sub QNo9002836_ExcelのVBAで教えてください。2()
Dim tempValue(1), i As Long, myInfo As String

tempValue(0) = Range("B4").Value
tempValue(1) = Range("G4").Value

myBoolean = True
For i = 0 To 1
If tempValue(i) = "" Then myInfo = "データ未入力"
tempValue(i) = Format(Replace(tempValue(i), "_JIK", ""), "0000-00-00 00:00:00")
Next i

If myInfo <> "データ未入力" Then
If IsDate(tempValue(0)) And IsDate(tempValue(1)) Then
If CDate(tempValue(1)) >= CDate(tempValue(0)) + TimeSerial(3, 0, 0) Then
myInfo = "OK"
Else
myInfo = "NG"
End If
Else
myInfo = "無効なデータ"
End If
End If
Range("J4").Value = myInfo

End Sub

>11個前までのフォルダを自動で選んで

　フォルダーに関して「11個前」とは、どういった意味なのでしょうか?
　又、もし11個前のフォルダーが存在しなかった場合にはどうした方が宜しいのでしょうか?(何も表示しないようにすれば良いのでしょうか?)
　又、11個前のフォルダーと選択したフォルダーとの間に日時に変換出来ない名称のフォルダーや、「20130322140311_JAK」の様な末尾に「_JIK」が付いていないフォルダーが挟まっていた場合にはどうすれば宜しいのでしょうか?(それらも含めて11個なのか?　それらのフォルダーの名称もセルに書き込むのか?)

補足

ご回答ありがとうございます。

頂いた　QNo9002836_ExcelのVBAで教えてください。1のマクロで目的の
フォルダ名の入力はできました。他の箇所に対応するときはRange("B4")のところを
対応箇所に修正していきたいと思います。

QNo9002836_ExcelのVBAで教えてください。2の方も判定のOK・NGがでることは
確認できました。ありがとうございます。
しかしながら、NGの場合3時間までの残り時間の表示がなかったですが、やはり
残り時間の表示は難しいでしょうか？

ご質問の

＞フォルダーに関して「11個前」とは、どういった意味なのでしょうか?

例えば【V:\新３係（ＦＩＡ・ｉＰｏｔ）\生産進捗表】このような階層で
生産進捗表のフォルダ内に質問文で書きました

20130322134700_JIK
20130322134855_JIK
20130322135021_JIK
20130322135146_JIK
20130322135312_JIK
20130322135438_JIK
20130322135603_JIK
20130322135729_JIK
20130322135854_JIK
20130322140020_JIK
20130322140145_JIK
20130322140311_JIK

のようなフォルダが100個以上あります。

＞又、もし11個前のフォルダーが存在しなかった場合にはどうした方が宜しいのでしょうか?(何も表示しないようにすれば良いのでしょうか?)

11個のフォルダが無い時に、このマクロを使用することはありません。
しかしながら、なにか処理をしなくてはいけないのであればおっしゃる通り何も表示しないように
して頂ければと思います。

＞又、11個前のフォルダーと選択したフォルダーとの間に日時に変換出来ない名称のフォルダーや、「20130322140311_JAK」の様な末尾に「_JIK」が付いていないフォルダーが挟まっていた場合にはどうすれば宜しいのでしょうか?(それらも含めて11個なのか?　それらのフォルダーの名称もセルに書き込むのか?)

日時に変換出来ない名称のフォルダーや_JIKがついていないフォルダが存在することはありません。
ここにあるフォルダは全てこのような20130322140311_JIKのような形式の型になります。

宜しくお願いします。