最終保存日時の表示方法について

このQ&Aのポイント
  • フォルダ内の「いろは.XLS」の最終保存日時を表示する方法について教えてください。
  • 現在、マクロで指定ディレクトリ内のフォルダ名を検索し、その中にある「いろは.XLS」の「C9」の値を取得しています。
  • 「いろは.XLS」が存在しない場合はファイル名のみを表示させたいです。どのようにすれば実現できますか?
回答を見る
  • ベストアンサー

最終保存日時の表示方法について

現在、下記のようなマクロで指定ディレクトリ内のフォルダ名を検索し、A3から下に標記 取得したフォルダ名の中にある「いろは.XLS」の「C9」の値をB3から下に標記 としております。「いろは.XLS」が必ずあるという前提でのマクロです。 Sub main() Const myPath As String = "D:\テスト\" Dim myFolder As String myFolder = Dir(myPath, vbDirectory) Dim r As Integer r = 3 Do While myFolder <> "" If myFolder <> "." And myFolder <> ".." Then If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then Cells(r, 1).Value = myFolder Cells(r, 2).Value = ExecuteExcel4Macro("'" & myPath & myFolder & "\[いろは.XLS]Sheet1 '!R9C3") r = r + 1 End If End If myFolder = Dir Loop End Sub 今回、C3から下に”各フォルダ内の「いろは.XLS」の最終保存日時”を標記し、「いろは.XLS」がない場合、ファイル名だけ取得したいのですが、どのようにすれば可能でしょうか? ExecuteExcel4Macroについてはファイルを開かないで操作するそうなのですが、サイトのコピペで造っていくしかまだ出来ない知識ですので、この形になっております。

質問者が選んだベストアンサー

  • ベストアンサー
  • keithin
  • ベストアンサー率66% (5278/7940)
回答No.1

Sub macro1()  Dim myPath As String  Dim myFolder As String  Dim r As Long  r = 3  myPath = "D:\テスト\"  myFolder = Dir(myPath, vbDirectory)  Do Until myFolder = ""   If myFolder <> "." And myFolder <> ".." Then   If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then    Cells(r, 1) = myFolder   ’最終更新日の取得    On Error Resume Next    Cells(r, 3) = FileDateTime(myPath & myFolder & "\いろは.xls")    On Error GoTo 0   ’セルの値の取得    Application.DisplayAlerts = False    Cells(r, 2).Value = ExecuteExcel4Macro("'" & myPath & myFolder & "\[いろは.XLS]Sheet1'!R9C3")    Application.DisplayAlerts = True   ’ファイルが入ってなかった場合    If Cells(r, 3) = "" Then     Cells(r, 2) = "いろは.xls"    End If    r = r + 1   End If   End If   myFolder = Dir()  Loop End Sub みたいな。

quindecillion
質問者

お礼

早々にお返事を頂きありがとうございます。 Application.DisplayAlerts = False    Cells(r, 2).Value = ExecuteExcel4Macro("'" & myPath & myFolder & "\[いろは.XLS]Sheet1'!R9C3")    Application.DisplayAlerts = True の部分なのですが、ExecuteExcel4MacroがApplication.DisplayAlertsの代役をしてくれるようなコマンドなので省かさせて頂き、無事マクロを走らせることができました。 FileDateTimeの標記を書式設定してm月で使えるように編集できれば目指す形にすることが可能です。 この度は本当にありがとうございました。

関連するQ&A

  • VBA 探しているFileがないときの処理方法

    現在、下記のようにしてマクロ実行ブックと同じ階層のフォルダ名を取得してAに、フォルダ内のabc.XLSのC9の値をBに、abc.XLSの更新日時をCに表示させています。 このとき、フォルダ内にabc.XLSが無い場合にファイル名をAに書き出してB及びCは空白というように表示したいのですが、どのようにすればよろしいでしょうか。 macro1は以前質問させて頂いたものがベースになっています。ExecuteExcel4Macroを使っている関係でファイル名が無いときの処理はDirを使ってできるとmougで調べてわかりましたが、自分の知識ではできず、macro2を作成したのですが、指定ファイルがない場合の処理がうまくできずにいます。 macro1はファイルオープンの窓が開きます。macro2はファイルが存在しないという窓が開きます。 どちらの場合でもかまいませんのでお力をお貸し頂けませんでしょうか。 Sub macro1() Dim myPath As String Dim myFolder As String Dim r As Long r = 3 myPath = ThisWorkbook.Path & "\" myFolder = Dir(myPath, vbDirectory) myBook = "abc.XLS" Application.ScreenUpdating = False Range("A3:C60").Clear Do Until myFolder = "" If myFolder <> "." And myFolder <> ".." Then If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then Cells(r, 1) = myFolder Cells(r, 2).Value = ExecuteExcel4Macro("'" & myPath & myFolder & "\[" & myBook & "]Sheet1 '!R9C3") On Error Resume Next Cells(r, 3) = FileDateTime(myPath & myFolder & "\" & myBook) On Error GoTo 0 If Cells(r, 3) = "" Then Cells(r, 2) = "myBook" End If Cells(r, 2).NumberFormatLocal = "#,##0_ " Cells(r, 3).NumberFormatLocal = "y""年""m""月""" With Range("A3:C60") .Sort Key1:=Range("C3"), Order1:=xlAscending .Borders.LineStyle = True End With r = r + 1 End If End If myFolder = Dir() Loop Application.ScreenUpdating = True End Sub Sub Macro2() Dim myPath As String Dim myFolder As String Dim myBook As String myPath = ThisWorkbook.Path & "\" myFolder = Dir(myPath, vbDirectory) myBook = "abc.XLS" i = 2 Do Until myFolder = "" If myFolder <> "." And myFolder <> ".." Then If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then Workbooks.Open (myPath & myFolder & "\" & myBook) Range("C9").Activate Selection.Copy ThisWorkbook.Activate Cells(i, 1) = myFolder Cells(i, 2).PasteSpecial xlValues Cells(i, 3) = FileDateTime(myPath & myFolder & "\" & myBook) Workbooks(myBook).Close SaveChanges:=False i = i + 1 End If End If myFolder = Dir() Loop End Sub

  • エクセル(VBA)でファイル名(サブフォルダ含む)、更新日時を表示させたい

    エクセルのVBAであるフォルダ以下の全てのファイル名と更新時間をエクセルシート上に表示させたく、以下のプログラムを作成したのですが 、サブフォルダ内のファイルを表示させることができません。何か良い方法がありましたら教えていただけないでしょうか?宜しくお願いいたします。 Sub SAMPLE() Dim serchPass As String j = 1 Mypath = "C:\My Documents\" MyName = Dir(Mypath, vbDirectory) Do While MyName <> "" ' ループを開始します。 ' 現在のフォルダと親フォルダは無視します。 If MyName <> "." And MyName <> ".." Then ' ビット単位の比較を行い、MyName がフォルダかどうかを調べます。 If (GetAttr(Mypath & MyName) And vbDirectory) = vbDirectory Then Debug.Print MyName ' フォルダであれば、それを表示します。 Else: GoTo 10 End If serchPass = Mypath & MyName With Application.FileSearch .NewSearch .LookIn = serchPass If .Execute() > 0 Then For i = 1 To .FoundFiles.Count Cells(i + j, 1).Value = .FoundFiles(i) Cells(i + j, 3) = FileDateTime(.FoundFiles(i)) Next i j = i + j End If End With 10 End If    MyName = Dir ' 次のフォルダ名を返します。 Loop End Sub

  • 他のブックを開かずに値を取得したい

    お世話になっております。。。 excel2007です。 アクティブである、ThisWorkbookに 外部ファイルから値のみ取得し、ThisWorkbookのA14セルからA27まで 入力させたい・・・ のですが、上手くいきません。 WEB検索して、ExecuteExcel4Macroでやってみたのですが、 Cells(1, C + 13) = ExecuteExcel4Macro("'strFullPath1'!受注書" & "Cells(2, C + 23)") のところで、「値の更新:strFullPath1」と出てしまいます。 どうしたら良いでしょうか? Private Sub CommandButton1_Click() Const FILE_DIR1 As String = "\\192.168.~" '途中までのパス Const FILE_DIR2 As String = "\\192.168.~~" '途中までのパス Dim strFullPath1 As String Dim strFullPath2 As String Dim strFileName As String Dim フォルダ名 As String Dim C As Integer フォルダ名 = TextBox2.Value & "\" & Range("B4") & "\" strFileName = "*" & Range("B5") & " " & Range("B6") & ".xls" strFullPath1 = FILE_DIR1 & フォルダ名 & strFileName strFullPath2 = FILE_DIR2 & フォルダ名 & strFileName C = 1 If Dir(strFullPath1) <> "" Then For C = 1 To 14 Cells(1, C + 13) = ExecuteExcel4Macro("'strFullPath1'!受注書" & "Cells(2, C + 23)") Next D Else For C = 1 To 14 Cells(1, C + 13).Formula = "[strFullPath2]sheet!cells(1,D+17)" Cells(1, C + 13).Value = Cells(D, 14).Value Next D End If Unload Me End Sub 端折っているので、抜けがあるかもしれません。 お知恵を頂けますでしょうか? 宜しくお願い致します。

  • Excel VBA ExecuteExcel4Macroについて

    こんにちは。よろしくお願いします。 あるフォルダ"D:\test"のなかに、4つのxlsファイル"o.xls"、"a.xls"、"b.xls"、"c.xls"があるとします。 使用するシート名は、それぞれo,a,b,c(ファイル名から".xls"を除いたもの)とします。 このとき"o.xls"を開いて、下記のマクロを実行すると、1行目にパス名、2行名にファイル名、3行目以下に(1列目は"a.xls"の、2列目は"b.xls"の、3列目は"c.xls"の)セルA3以下が読み込まれます。 たとえば、結果は添付の図のようになります。図がうまくアップできなかったらごめんなさい。 Sub sample1() Application.Calculation = xlManual Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Worksheets("o").Cells.Clear Dim p As String, fn As String, fc As Long, i As Long, j As Long, d, e p = ActiveWorkbook.Path fn = Dir(p & "\" & "*.xls", 0) fc = 0 If fn <> "" Then fc = fc + 1 For j = 3 To 6 With Worksheets("o") .Cells(1, fc).Value = p & "\" & fn .Cells(2, fc).Value = fn d = ExecuteExcel4Macro("'" & p & "\[" & fn & "]" & Mid(fn, 1, Len(fn) - 4) & "'!R" & j & "C1") If d = 0 Or IsError(d) Then Exit For Else .Cells(j, fc) = d End If End With Next j End If Do fn = Dir() If fn <> "" Then fc = fc + 1 For i = 3 To 6 With Worksheets("o") .Cells(1, fc).Value = p & "\" & fn .Cells(2, fc).Value = fn e = ExecuteExcel4Macro("'" & p & "\[" & fn & "]" & Mid(fn, 1, Len(fn) - 4) & "'!R" & i & "C1") If e = 0 Or IsError(d) Then Exit For Else .Cells(i, fc) = e End If End With Next i Else Exit Do End If Loop Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Calculation = xlAutomatic End Sub 上記の例は変数iとjが3から6までしか動きませんし、読み込むxlsファイルも3つしかありませんのですぐに終わりますが、実際には行やファイルがもっとたくさんあり、非常に時間がかかっています。そこで、 ExecuteExcel4Macro("'" & p & "\[" & fn & "]" & Mid(fn, 1, Len(fn) - 4) & "'!R" & i & "C1") を e = ExecuteExcel4Macro("'" & p & "\[" & fn & "]" & Mid(fn, 1, Len(fn) - 4) & "'!R3C1:R6C1") というような風にして、For~Nextも使用せず .range(Cells(3, fc),cells(6, fc)) = e というふうに範囲で読み込もうとしたのですがうまくいきません。 ExecuteExcel4Macroは範囲を読み込むことはできないのでしょうか? 何とかして処理速度を上げたいのですが、どうすればよいでしょうか。

  • EXCELのVBAにて閉じたブックの数値を拾い出したいため

    EXCELのVBAにて閉じたブックの数値を拾い出したいため ExecuteExcel4Macroを使用して次のように作成しましたが 生産管理ブック内の直出荷シートしか参照できません。 その他シートの参照して数値を拾い出したいため シートのループ処理(シート数不規則)を例えばworksheet(1)~処理終了の名前がついた シートまで行いたいのですがどの様に直出荷部分を書き込めばいいかわかりません。 いい方法を教えていただけ無いでしょうか? (:と生産計画の間 エン[ がうまく表示できません) Dim i As Long, idx As Long Dim hi As Integer For hi = 10 To 252 If Cells(2, 3) = ExecuteExcel4Macro("'E:\生産計画.xls]直出荷'!R" & 11 & "C" & hi) Then Exit For End If Next hi i = 7 For idx = 7 To 3000 For i = i To 300 If ExecuteExcel4Macro("'E:\生産計画.xls]直出荷'!R" & idx & "C" & 5) = 0 Then Exit Sub End If Cells(i, 1) = ExecuteExcel4Macro("'E:\生産計画.xls]直出荷'!R" & idx & "C" & 5) Cells(i, 2) = ExecuteExcel4Macro("'E:\生産計画.xls]直出荷'!R" & idx + 2 & "C" & 5) Cells(i, 3) = ExecuteExcel4Macro("'E:\生産計画.xls]直出荷'!R" & idx + 11 & "C" & hi) i = i + 1 Exit For Next i idx = idx + 57 Next idx

  • Excel2000のマクロが2007で型が一致しませんと表示されます

    自作マクロを作成し別ブックから転記するものですがExcel2000では正常に動くのですが、Excel2007では、転記対象のセルが0なら空白にするという行(IF文)で「型が一致しません」と表示されてしまいます。 ExecuteExcel4Macroが悪いのか、いろいろ調べましたが型とは?などマクロ初心者なので分からないです。宜しくお願いします。 For i = 1 To 7 Cells(i, 1).Value = ExecuteExcel4Macro("'\[meca.xls]Sheet1'!R" & i & "C1") If ExecuteExcel4Macro("'\[meca.xls]Sheet1'!R" & i & "C1") = "0" Then Cells(i, 1).Value = "" Next i

  • エクセルVBAで困っています。

    Excell2003でマクロを作成したのですが、思うような結果が出なくて困っています。 どなたかお力をお貸しください。 お願いします。 【作成したマクロ】 Sub テスト()   myPath = ThisWorkbook.Path   buf = Dir(myPath & "¥データ¥" & "*.xls")   Do While buf <> ""     Target = "'" & myPath & "[" & buf & "]Sheet1'!R1C1"     i = i + 1     Cells(i, 1) = buf     Cells(i, 2) = ExecuteExcel4Macro(Target)     buf = Dir()   Loop End Sub 【設定状況】 ・デスクトップ上に "サンプル.xls" があり、ThisWorkBookに上記マクロを書きました。 ・デスクトップ上に "データ" というフォルダがあり、その中に、"Book1.xls" と "Book2.xls" があります。 ・"Book1.xls" のSheet1のRange("A1")には "あいうえお" が入力されています。 ・"Book2.xls" のSheet1のRange("A1")には "かきくけこ" が入力されています。 【マクロ実行結果】 ・Range("A1") ・・・ Book1.xls ・Range("B1") ・・・ #REF! ・Range("A2") ・・・ Book2.xls ・Range("B2") ・・・ #REF! となってしまいます。 【求めたい結果】 ・Range("A1") ・・・ Book1.xls ・Range("B1") ・・・ あいうえお ・Range("A2") ・・・ Book2.xls ・Range("B2") ・・・ かきくけこ よろしくお願いします。

  • フォルダー名に特殊文字?が存在する場合にエラー発生

    以下のコードでフォルダー名を取得しています。 しかし、フォルダー名に特殊文字?が存在する場合に下記でエラーが発生します。  例えば「Oxygène」 でeの上に’があるなど   If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then      実行エラー 53: ファイルが見つかりません。 これは、excelの仕様で処理できないのでしょうか ? 他のコードで処理できれば教えて下さい。 --------------------------------------- Sub フォルダ名取得() Dim MyName Dim MyPath Dim i As Long ’仮の消込(初期化: 前回の記入文をクリアー) Range("A5:H50").Clear i = 1 ' フォルダーを自由に選べること。 参考:officeTANAKA With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then ' MsgBox .SelectedItems(1) If Len(.SelectedItems(1)) = 3 Then ' c:\の場合とサブフォルダーの場合 MyPath = .SelectedItems(1) Else MyPath = .SelectedItems(1) & "\" End If End If End With If MyPath = Empty Then MsgBox "フォルダー名表示をキャンセルしました。": Exit Sub 'Range("b2:c2").ShrinkToFit = True ' 縮小してセル内に表示 MyName = Dir(MyPath, vbDirectory) ' 最初のフォルダ名を返します。 '親フォルダー Range("A2") = MyPath Do While MyName <> "" ' ループを開始します。 ' 現在のフォルダと親フォルダは無視します。 If MyName <> "." And MyName <> ".." Then ' ビット単位の比較を行い、MyName がフォルダかどうかを調べます。 If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then Range("a" & i + 4) = MyPath & MyName ' アクティブシートA5セルから下方にフルパス表示。 Range("b" & i + 4) = MyName ' アクティブシートB5セルから下方にフォルダ名表示 i = i + 1 End If End If MyName = Dir ' 次のフォルダ名を返します。 Loop MsgBox MyPath & "の中にフォルダーは" & (i - 1) & "個のフォルダーがありました。" End Sub

  • エクセルでフォルダまたはファイルを開くマクロですが、どのように改良すれ

    エクセルでフォルダまたはファイルを開くマクロですが、どのように改良すればよろしいでしょうか? 下記マクロは、エクセルシートのJ列のあるセルをダブルクリックすると、そのセルに記入された文字列を検索して、該当のフォルダまたは、写真が開きます。(エクセルファイルと写真は同フォルダに保存している場合のみ有効) 困っていることは、J列のセルと該当フォルダまたは、写真ファイルをリンクさせたいのですが、文字列が全て一致している時のみしか開かないことです。 D<デジカメ<商品名フォルダ<写真ファイル 例えば セルJ3の文字列がABCEで、フォルダ名またはファイル名がABCDEFであった場合、文字列ABCEを含む条件で、フォルダ名またはファイル名ABCDEFを開くように改良したいのですが、 また、エクセルファイルと写真ファイルの保存場所は、全く違うフォルダにしたいのですが、 エクセルファイルと写真ファイルは、別フォルダの場合、どのように検索先フォルダのパスを入れたら良いのでしょうか? マクロに詳しい方ご教授下さい。よろしくお願い致します。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim myPath As String If Target.Cells(1, 1).Column <> 10 Then Exit Sub Cancel = True myPath = ThisWorkbook.Path & "\" & Target.Cells(1, 1).Text If Dir(myPath, vbDirectory) <> "" Then Shell "explorer.exe /e,/root," & myPath, vbNormalFocus Exit Sub End If myPath = Replace(LCase(myPath), ".jpg", "\" & Target.Cells(1, 1).Text) If Dir(myPath, vbNormal) <> "" Then Shell "rundll32.exe shimgvw.dll,ImageView_Fullscreen " & myPath, vbNormalFocus End If End Sub

  • 実行時エラー9:インデックスが有効範囲にありません」ができてた。調べた

    実行時エラー9:インデックスが有効範囲にありません」ができてた。調べたのですが、原因は分からない、皆さん、助けてください。 以下はあるフォルダーを選定して、セルの値と一致するファイルを探し出して、シートAの中のデータを取り上げて、コピーしたいです。けど、エラーが出てきた。皆さん。よろしくお願いします。 Sub test() Dim forName, bookName As String Dim x, y, l As Long Const cnsDIR = "\*.xls" Dim bFound As Boolean Dim myBook, actBook As Workbook Dim mySheet, actSheet As Worksheet With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then myPath = .SelectedItems(1) End If End With forName = Dir(myPath, vbDirectory) If Dir(myPath, vbDirectory) = "" Then MsgBox "It's nothing!", vbExclamation Exit Sub End If bFound = False For x = 2 To 7 Step 1 bookName = Dir(myPath & cnsDIR, vbNormal) Do While bookName <> "" l = InStrRev(bookName, ".xls") If Mid(bookName, l - 4, 4) = Format(Cells(4, x), "0000") Then bFound = True Exit Do 'hang/lie Else bookName = Dir() End If Loop If bFound = False Then Rtn = MsgBox("This is no found. Do you want to continue?", vbYesNo, "選択") If Rtn = vbNo Then Exit For End If Windows(bookName).Activate actSheet = ActiveWorkbook.Sheets For Each actSheet In Worksheets If ActiveSheet.Name = "A" Then Application.Union(Range("C55:F55"), Range("H55:I55")).Copy ThisWorkbook.Sheets(4).Range("B5").PasteSpecial Paste:=xlValues, Transpose:=True End If Next Next x End Sub

専門家に質問してみよう