【マクロ】売上一覧YYYYMMDDHHSS.xls形式のブックをファイル名一覧から抽出⇒変数に入れる

【やりたい事】
以下画像をご覧ください
１C列に約５～10個のファイル名が並んでいる
２ファイル一覧から、売上一覧YYYYMMDDHHSS.xls　形式のファイル名をA2へ抽出(関数orマクロ)
３A2のファイル名前と、A4のシート名（変わらない）を変数に入れたいです

ご存じの方、アドバイスorコードを教えて下さい
宜しくお願いします

No.5 回答者： tatsumaru77 回答日時： 2025/04/20 20:03

>aaaaaaaaaaYYYYMMDDHHNNSS.csv

>aが１０個です

修正しました。
Public Sub ブック名転記()
Dim ws As Worksheet
Dim wrow As Long
Dim lastrow As Long
Dim ret As Boolean
Set ws = ActiveSheet
lastrow = ws.Cells(Rows.Count, "C").End(xlUp).Row
ws.Range("A2").Value = ""
For wrow = 2 To lastrow
ret = CheckName(ws.Cells(wrow, "C").Value)
If ret = True Then
ws.Range("A2").Value = ws.Cells(wrow, "C").Value
Exit For
End If
Next
If ws.Range("A2").Value = "" Then
MsgBox ("aaaaaaaaaaYYYYMMDDHHNNSS.csv　形式のファイルはありません")
Exit Sub
End If
Dim book_name As String
Dim sheet_name As String
book_name = ws.Range("A2").Value
sheet_name = ws.Range("A4").Value
MsgBox (book_name)
MsgBox (sheet_name)
End Sub
Private Function CheckName(ByVal name As String) As Boolean
CheckName = False
'28文字でないならエラー
If Len(name) <> 28 Then Exit Function
'先頭10文字が aaaaaaaaaa でないならエラー
If Left(name, 10) <> "aaaaaaaaaa" Then Exit Function
'末尾の4文字が .csv(大文字可) でないならエラー
If LCase(Right(name, 4)) <> ".csv" Then Exit Function
'YYYYMMDDHHNNSSが日付・時刻として正しくないならエラー
Dim dt As String
Dim date_time As String
dt = Mid(name, 11, 14)
If IsNumeric(dt) = False Then Exit Function
date_time = Left(dt, 4) & "/" & Mid(dt, 5, 2) & "/" & Mid(dt, 7, 2) & " " & Mid(dt, 9, 2) & ":" & Mid(dt, 11, 2) & ":" & Mid(dt, 13, 2)
If IsDate(date_time) = False Then Exit Function
CheckName = True
End Function

この回答へのお礼

大変有用なコードごしなん、ありがとうございました！

お礼日時：2025/04/21 14:50

No.4 回答者： tatsumaru77 回答日時： 2025/04/20 18:23

>ちなみに

>aaaaaaaaaa20250420180001.xls
>※aは１０個　変更
>の変更につき、以下コードを、変更しましたが動きませんでした
>他、変更する所があれば教えて下さい

修正しました。
Public Sub ブック名転記()は、
MsgBox ("aaaaaaaaaaYYYYMMDDHHNNSS.xlsx　形式のファイルはありません")
の行のみ修正しています。
Private Function CheckName(ByVal name As String) As Boolean
は、全面的に変更しています。

-----------------------------------------
Public Sub ブック名転記()
Dim ws As Worksheet
Dim wrow As Long
Dim lastrow As Long
Dim ret As Boolean
Set ws = ActiveSheet
lastrow = ws.Cells(Rows.Count, "C").End(xlUp).Row
ws.Range("A2").Value = ""
For wrow = 2 To lastrow
ret = CheckName(ws.Cells(wrow, "C").Value)
If ret = True Then
ws.Range("A2").Value = ws.Cells(wrow, "C").Value
Exit For
End If
Next
If ws.Range("A2").Value = "" Then
MsgBox ("aaaaaaaaaaYYYYMMDDHHNNSS.xlsx　形式のファイルはありません")
Exit Sub
End If
Dim book_name As String
Dim sheet_name As String
book_name = ws.Range("A2").Value
sheet_name = ws.Range("A4").Value
MsgBox (book_name)
MsgBox (sheet_name)
End Sub
Private Function CheckName(ByVal name As String) As Boolean
CheckName = False
'29文字でないならエラー
If Len(name) <> 29 Then Exit Function
'先頭10文字が aaaaaaaaaa でないならエラー
If Left(name, 10) <> "aaaaaaaaaa" Then Exit Function
'末尾の5文字が .xlsx(大文字可) でないならエラー
If LCase(Right(name, 5)) <> ".xlsx" Then Exit Function
'YYYYMMDDHHNNSSが日付・時刻として正しくないならエラー
Dim dt As String
Dim date_time As String
dt = Mid(name, 11, 14)
If IsNumeric(dt) = False Then Exit Function
date_time = Left(dt, 4) & "/" & Mid(dt, 5, 2) & "/" & Mid(dt, 7, 2) & " " & Mid(dt, 9, 2) & ":" & Mid(dt, 11, 2) & ":" & Mid(dt, 13, 2)
If IsDate(date_time) = False Then Exit Function
CheckName = True
End Function

この回答へのお礼

大変、申し訳ございません。拡張子を間違っていました
お手すきな時、教えて下さい。宜しくお願いします

aaaaaaaaaaYYYYMMDDHHNNSS.csv
aが１０個です

お礼日時：2025/04/20 18:39

No.3 回答者： fujillin 回答日時： 2025/04/18 16:09

こんにちは

スピル機能が使えるバージョンなら、関数でも可能です。

A2セルに
=LET(a,REGEXEXTRACT(C2:C11,"^売上一覧[0-9]{4}(0[1-9]|1[0-2])(0[1-9]|[12][0-9]|3[01])([01][0-9]|2[0-3])[0-5][0-9][0-5][0-9]\.xls(x)?$"),INDEX(FILTER(a,NOT(ISERROR(a)),""),1))
とか。

日付、時刻のチェックを緩くしても良ければ、
=LET(a,REGEXEXTRACT(C2:C11,"^売上一覧[0-9]{14}\.xls(x)?$"),INDEX(FILTER(a,NOT(ISERROR(a)),""),1))
でも可能かと。

この回答へのお礼

関数でのご指導ありがとうございます
質問なのですが、自宅パソコン→サブスクExcelにて普通にできましたが


他のパソコンで実施したら、出来ませんでした→関数の所に緑三角→エラーインジケーターがでます、バージョンは、以下です

以下バージョンでも使えるようにする
アドバイスありまたら、お願いします

バージョン
Microsoft 365 Apps for enterprise

お礼日時：2025/04/21 14:53

No.2 回答者： tatsumaru77 回答日時： 2025/04/18 14:12

以下のようにしてください

A2のファイル名は変数book_name　に格納、
A4のシート名は変数sheet_name　に格納しています。
それぞれ、メッセージボックスに表示しています。



Option Explicit

Public Sub ブック名転記()
Dim ws As Worksheet
Dim wrow As Long
Dim lastrow As Long
Dim ret As Boolean
Set ws = ActiveSheet
lastrow = ws.Cells(Rows.Count, "C").End(xlUp).Row
ws.Range("A2").Value = ""
For wrow = 2 To lastrow
ret = CheckName(ws.Cells(wrow, "C").Value)
If ret = True Then
ws.Range("A2").Value = ws.Cells(wrow, "C").Value
Exit For
End If
Next
If ws.Range("A2").Value = "" Then
MsgBox ("売上一覧YYYYMMDDHHNNSS.xlsx　形式のファイルはありません")
Exit Sub
End If
Dim book_name As String
Dim sheet_name As String
book_name = ws.Range("A2").Value
sheet_name = ws.Range("A4").Value
MsgBox (book_name)
MsgBox (sheet_name)
End Sub
Private Function CheckName(ByVal name As String) As Boolean
CheckName = False
'23文字でないならエラー
If Len(name) <> 23 Then Exit Function
'先頭4文字が 売上一覧 でないならエラー
If Left(name, 4) <> "売上一覧" Then Exit Function
'末尾の5文字が .xlsx(大文字可) でないならエラー
If LCase(Right(name, 5)) <> ".xlsx" Then Exit Function
'YYYYMMDDHHNNSSが日付・時刻として正しくないならエラー
Dim dt As String
Dim date_time As String
dt = Mid(name, 5, 14)
If IsNumeric(dt) = False Then Exit Function
date_time = Left(dt, 4) & "/" & Mid(dt, 5, 2) & "/" & Mid(dt, 7, 2) & " " & Mid(dt, 9, 2) & ":" & Mid(dt, 11, 2) & ":" & Mid(dt, 13, 2)
If IsDate(date_time) = False Then Exit Function
CheckName = True
End Function

この回答へのお礼

すごい、コードの教授ありがとうございます
うまく、動きました

ちなみに
aaaaaaaaaa20250420180001.xls
※aは１０個　変更

の変更につき、以下コードを、変更しましたが動きませんでした
他、変更する所があれば教えて下さい

CheckName = False
'23文字でないならエラー

If Len(name) <> 28 Then Exit Function

'先頭4文字が 売上一覧 でないならエラー
If Left(name, 10) <> "aaaaaaaaaa" Then Exit Function

'末尾の5文字が .xlsx(大文字可) でないならエラー
If LCase(Right(name, 4)) <> ".csv" Then Exit Function

お礼日時：2025/04/20 18:06

No.1 回答者： tatsumaru77 回答日時： 2025/04/18 11:25

補足要求です。

ファイル名は、
売上一覧YYYYMMDDHHSS.xls　形式
となっていますが、
実際の例は、
売上一覧YYYYMMDDHHNNSS.xlsx　形式です。

①正しい拡張子は、xlsなのかそれともxlsxなのかが不明です。（もしくは両方とも正しい）
②YYYYMMDDHHSSはYYYYMMDDHHNNSSの誤りと理解して良いでしょうか。（NNは分）

この回答へのお礼

1→YYMMDDHHNNSS
→14ケタです→こちらの間違いです

2　xlsx　yahoo.co.jp通常のExcel拡張子です

お礼日時：2025/04/18 13:39