VBAで「エクセルに写真を貼り付け、外のセルに撮影月日を『和暦』で自動記載」させたい

前提として、VBA超初心者です。４日前に初めてVBAを知った位です…。

仕事で「現場写真」を数百～千枚程度整理し、エクセルで「写真帳」を作る必要があります。
その際に、貼り付けた写真の横に、撮影月日を「和暦」で記載する必要もあります。
今までは、貼り付けるものが工事写真なので、写り込んでいる黒板の日付を確認して、手入力で日付を記載していましたが…日付の判読が難しいもの等は、都度、画像のプロパティーを開き、撮影月日を確認してから入力する必要もあり…
流石に扱う枚数が増えると、この作業だけの為に費やす時間が膨大で…。
「写真を貼り付けたら、自動で日付を『和暦』で記載させられないか？」
と考え、VBAに手を出した所です。

ネットでかなり理想に近しいVBAを見つけられましたが…
如何せん日付が「西暦表示で時間まで記載」されるタイプで…。

「和暦」への返還方法を求めて、試行錯誤し、「VBA初心者講座」等も読破しましたが…。
どうしても改良が上手くいかないまま3日過ごしています。
何分、工期もあり、「上手くいかなければ手入力」と考えると…
これ以上悠長に時間を避けません。

そこで、下記のVBAを「時間は省き、日付を和暦で記載」する改良方法を、
恥を忍んで先人の方々に教えを請わせて戴きます。


Sub 写真挿入日付自動記載試験版()
' 関数の宣言
Dim objFS, objFile, shellObj, folderObj, myPic, MyFile, myPath
' 画像の選択、関数代入
myPic = Application.GetOpenFilename(Title:="＊＊＊ 貼り付ける画像の選択 ＊＊＊")
If myPic = False Then Exit Sub
ActiveSheet.Pictures.Insert(myPic).Select
With Selection
' 貼り付け位置の設定
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Width = 640 '画像の縦横比は現在4:3、サイズと比を自由に設定
.Height = 480
End With
' 関数代入
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFile = objFS.GetFile(myPic)
MyFile = objFile.Name
myPath = Replace(myPic, MyFile, "")
myPath = Left(myPath, Len(myPath) - 1)
Set shellObj = CreateObject("Shell.Application")
Set folderObj = shellObj.Namespace(myPath)
' 日付記載位置（貼り付けたJPGのセルから、「下に15行、右に２列」のセルに記載）
ActiveCell.Offset(15, 2) = folderObj.GetDetailsOf(folderObj.ParseName(MyFile), 12) 'Xpの場合、Vista,7は１２にする
Set objFS = Nothing
Set objFile = Nothing
Set shellObj = Nothing
Set folderObj = Nothing
End Sub

システム環境はWIN7、エクセル2010です。

どうか宜しくお願いいたします。

No.8 ベストアンサー 回答者： GooUserラック 回答日時： 2017/06/04 11:25

非常に厄介ですし、実際の内容がこちらでは把握できないので、最適ではありませんが「ActiveCell.Offset(15, 2) = folderObj.GetDetailsOf(folderObj.ParseName(MyFile), 12)」の後に次の数行を足してみてください。

---------------------------------------------------------------------------------------------------
Dim i, DatStr, DateStr
With ActiveCell.Offset(15, 2)
DatStr = .Value
For i = 1 To Len(.Value)
If IsNumeric(Mid(.Value, i, 1)) Then
DateStr = DateStr & Mid(.Value, i, 1)
If Len(DateStr) = 4 Then DateStr = DateStr & "/"
If Len(DateStr) = 7 Then DateStr = DateStr & "/"
If Len(DateStr) = 10 Then Exit For
End If
Next
.Value = CDate(DateStr)
.NumberFormatLocal = "[$-411]ggge""年""m""月""d""日"";@"
End With
---------------------------------------------------------------------------------------------------
何をやっているかというと、
① １文字ずつ数字かどうか確認して数字だったら抜き出して文字列を作っていきます。
② ４桁になったら「年」の部分が出来たので「/」を足します。(「yyyy/」になります)
③ ７桁になったら「月」の部分までが出来たので「/」を足します。(「yyyy/mm/」になります)
④ １０桁になったら日付まで出来たので次に進みます。(「yyyy/mm/dd」になります)
⑤「DateStr」を「CDate」関数を使って日付(シリアル値)に変換し元と入れ替えます。
⑥ 書式を変更します。

もし時間も表示はしたくないけど残したいのならば
---------------------------------------------------------------------------------------------------
With ActiveCell.Offset(15, 2)
DatStr = .Value
For i = 1 To Len(.Value)
If IsNumeric(Mid(.Value, i, 1)) Then
DateStr = DateStr & Mid(.Value, i, 1)
If Len(DateStr) = 4 Then DateStr = DateStr & "/"
If Len(DateStr) = 7 Then DateStr = DateStr & "/"
If Len(DateStr) = 10 Then DateStr = DateStr & " "
If Len(DateStr) = 13 Then DateStr = DateStr & ":"
If Len(DateStr) = 16 Then Exit For
End If
Next
.Value = CDate(DateStr)
.NumberFormatLocal = "[$-411]ggge""年""m""月""d""日"";@"
End With
---------------------------------------------------------------------------------------------------

この回答へのお礼

何度もすいません…。
本当にありがとうございます

.Value = CDate(DateStr)

の部分で
実行エラー13
型が一致しません

と出ました。

あと、№5のお礼でが尻切れになっていましたので、追記させていただきます。

写真貼り付け位置はB1セル
日時の記載セルはD16（正確にはD16～F17の結合セル）
です

但し、同一シートに写真3段。印刷シートを変えて更に複数の…
なので、セルの個別指定は難しいです。

お礼日時：2017/06/04 12:04

No.7 回答者： GooUserラック 回答日時： 2017/06/04 10:34

表示が「?2017/?04/?29??13:14」ですと面倒ですね

「ActiveCell.Offset(15, 2) = folderObj.GetDetailsOf(folderObj.ParseName(MyFile), 12)」の次の行に「MsgBox (ActiveCell.Offset(15, 2).Text)」と入れて実行したときににまだ「?」が表示されてしまいますか？

この回答へのお礼

＞表示が「?2017/?04/?29??13:14」ですと面倒ですね
Σ(￣Д￣;)なぬぅっ!!
マジですか…。
手入力まっしぐらですか…。
市ぬんですか？俺…。


とりあえず…結果

「?2017/?04/?29??13:14」

でした

お礼日時：2017/06/04 10:45

No.6 回答者： GooUserラック 回答日時： 2017/06/04 10:14

No.3 の訂正　何をやっているのでしょうか？　申し訳ございません。

それでしたら「ActiveCell.Offset(15, 2) = folderObj.GetDetailsOf(folderObj.ParseName(MyFile), 12)」を「ActiveCell.Offset(15, 2) = CDate(folderObj.GetDetailsOf(folderObj.ParseName(MyFile), 12))」とかではどうですか？

この回答へのお礼

何度も何度もすいません
教えていただいた書式は、質問時に記載した基本VBAに立ち戻ってから、追記して試しています。

ActiveCell.Offset(15, 2) = CDate(folderObj.GetDetailsOf(folderObj.ParseName(MyFile), 12))

実行エラー13
型が一致しません

と出ました。

お礼日時：2017/06/04 10:37

No.5 回答者： GooUserラック 回答日時： 2017/06/04 10:09

No.4 の追補

もし日時が表示されたのならば「ActiveCell.Offset(15, 2) = folderObj.GetDetailsOf(folderObj.ParseName(MyFile), 12)」の次の行に「ActiveCell.Offset(15, 2).Value = CDate(ActiveCell.Offset(15, 2).Value)」と「ActiveCell.Offset(15, 2).NumberFormatLocal = "[DBNum3][$-411]ggge""年""m""月""d""日"";@"」で行けそうです。

もし日時が表示されないようでしたら、表示されているセルの位置が違うのだと思います。
写真の貼り付けたセル番号と日時が表示されているセル番号を教えてください。

また、日時以外が含まれている物が表示されたのならば、サンプルとして提示していただければ対応できるかもしれません。

この回答へのお礼

何度もお手を煩わせてすいません…。

ActiveCell.Offset(15, 2) = folderObj.GetDetailsOf(folderObj.ParseName(MyFile), 12)
ActiveCell.Offset(15, 2).Value = CDate(ActiveCell.Offset(15, 2).Value)
ActiveCell.Offset(15, 2).NumberFormatLocal = "[DBNum3][$-411]ggge""年""m""月""d""日"";@"

の結果

ActiveCell.Offset(15, 2).Value = CDate(ActiveCell.Offset(15, 2).Value)

の型が一致しないらしいです。

写真貼り付け位置はB1セル

お礼日時：2017/06/04 10:27

No.4 回答者： GooUserラック 回答日時： 2017/06/04 10:00

「ActiveCell.Offset(15, 2) = folderObj.GetDetailsOf(folderObj.Pars

eName(MyFile), 12)」の次の行に「MsgBox (ActiveCell.Offset(15, 2).Value)」と入れて実行したときに何が表示されますか？

この回答へのお礼

Sub 写真挿入日付自動記載試験版()
' 関数の宣言
Dim objFS, objFile, shellObj, folderObj, myPic, MyFile, myPath
' 画像の選択、関数代入
myPic = Application.GetOpenFilename(Title:="＊＊＊ 貼り付ける画像の選択 ＊＊＊")
If myPic = False Then Exit Sub
ActiveSheet.Pictures.Insert(myPic).Select
With Selection
' 貼り付け位置の設定
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Width = 640 '画像の縦横比は現在4:3、サイズと比を自由に設定
.Height = 480
End With
' 関数代入
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFile = objFS.GetFile(myPic)
MyFile = objFile.Name
myPath = Replace(myPic, MyFile, "")
myPath = Left(myPath, Len(myPath) - 1)
Set shellObj = CreateObject("Shell.Application")
Set folderObj = shellObj.Namespace(myPath)
' 日付記載位置（貼り付けたJPGのセルから、「下に15行、右に２列」のセルに記載）
ActiveCell.Offset(15, 2) = folderObj.GetDetailsOf(folderObj.ParseName(MyFile), 12) 'Xpの場合、Vista,7は１２にする
MsgBox (ActiveCell.Offset(15, 2).Value)
Set objFS = Nothing
Set objFile = Nothing
Set shellObj = Nothing
Set folderObj = Nothing
End Sub

の結果

「?2017/?04/?29??13:14」

でした

お礼日時：2017/06/04 10:16

No.3 回答者： GooUserラック 回答日時： 2017/06/04 09:41

それでしたら「ActiveCell.Offset(15, 2) = folderObj.GetDetailsOf(folderOb

j.ParseName(MyFile), 12)」を「CDate(ActiveCell.Offset(15, 2) = folderObj.GetDetailsOf(folderObj.ParseName(MyFile), 12))」とかではどうですか？

この回答へのお礼

更にありがとうございます！

ですが…
構文エラーが出てしまいます…。
エラーの修正方法も判りません…。

お礼日時：2017/06/04 09:50

No.2 回答者： GooUserラック 回答日時： 2017/06/04 09:26

No.1 の追補

数字を全角にした方が良ければ「ActiveCell.Offset(15, 2).NumberFormatLocal = "[DBNum3][$-411]ggge""年""m""月""d""日"";@"」も良いと思います。

この回答へのお礼

お気遣いありがとうございます！

ですが…
日付表示は
「‎2017/‎04/‎29 ‏‎13:14」
の様に、和暦には直りませんでした…。

お礼日時：2017/06/04 09:48

No.1 回答者： GooUserラック 回答日時： 2017/06/04 09:18

和暦は書式設定だけ変更すれば良いと思います。

「ActiveCell.Offset(15, 2) = folderObj.GetDetailsOf(folderObj.ParseName(MyFile), 12)」の次の行に「ActiveCell.Offset(15, 2).NumberFormatLocal = "[$-411]ggge""年""m""月""d""日"";@"」などで良いのでは？

この回答へのお礼

神の如く早い回答ありがとうございます！

ですが…
日付表示は
「‎2017/‎04/‎29 ‏‎13:14」
の様に、和暦には直りませんでした…。

原因を思案中ですが…
撮影日時からの取得だと「文字列」になるのでしょうか？

お礼日時：2017/06/04 09:33