'正規表現のグループ変数による部分置換
Function FindDateX(argStr As String) As Variant
With CreateObject("VBScript.RegExp")
.Global = False
.Pattern = ".*?\((\d{4})\D?(\d{1,2})\D?(\d{1,2})[^)]?(?=\)).*"
If .Test(argStr) Then
Dim sDate As String
sDate = .Replace(argStr, "$1/$2/$3")
If IsDate(sDate) Then FindDateX = CDate(sDate)
End If
End With
End Function
'呼び出し例
Sub Test2()
Debug.Print FindDateX("C:\Users\中略\発注書(2023.12.19).xls")
Debug.Print FindDateX("C:\Users\中略\発注書(2023年12月19日).xls")
Debug.Print FindDateX("C:\Users\中略\発注書(20231219).xls")
Debug.Print FindDateX("C:\Users\中略\発注書(2023-12-9).xls")
End Sub
Function FindDate(Expression As String) As Variant
FindDate = Null
If Expression = "" Then
Exit Function
End If
Dim objRegExp As Object
Dim objMatches As Object
Dim objMatch As Object
Dim strPattern As String
Dim strMatchValue As String
Set objRegExp = CreateObject("VBScript.RegExp")
strPattern = "\d+(-|/|\.)\d{1,2}(-|/|\.)\d+"
With objRegExp
.Pattern = strPattern
.IgnoreCase = True
.Global = True
Set objMatches = .Execute(Expression)
End With
For Each objMatch In objMatches
strMatchValue = Replace(objMatch.Value, ".", "/", 1, -1, vbTextCompare)
If IsDate(strMatchValue) = True Then
FindDate = CDate(strMatchValue)
Exit For
End If
Next
Set objMatches = Nothing
Set objRegExp = Nothing
End Function
'呼び出し例
Sub Test1()
Dim strFullPath As String
Dim strFileName As String
strFullPath = "C:\Users\中略\発注書(2023-12.19).xls"
strFileName = Dir(strFullPath)
If strFileName = "" Then
MsgBox "ファイル'" & strFullPath & "'が見つかりません。", _
vbExclamation, _
"ファイル参照エラー"
Exit Sub
End If
Dim varDate As Variant
varDate = FindDate(strFileName)
If IsNull(varDate) Then
MsgBox "ファイル名'" & strFileName & "'には日付データに変換可能な文字列は含まれていません。", _
vbExclamation, _
"ファイル命名規則エラー"
Else
MsgBox "ファイル名'" & strFileName & "'から日付 " & Format(varDate, "yyyy/mm/dd") & "を取得しました。", _
vbInformation, _
"成功"
End If
End Function
Function GetDate(s As String) As Variant
Dim vTmp As Variant
Dim sDate As String
vTmp = Split("(" & Replace(s, ")", "("), "(")
sDate = Replace(vTmp(UBound(vTmp) - 1), ".", "/")
If IsDate(sDate) Then GetDate = CDate(sDate)
End Function
Function GetDate(s As String) As Variant
Dim pos1 As Long, pos2 As Long, l As Long
pos1 = InStr(s, "("): pos2 = InStr(s, ")")
l = pos2 - pos1 - 1
If l >= 8 Then
Dim sDate As String
sDate = Mid(s, pos1 + 1, l)
sDate = Replace(sDate, ".", "/")
If IsDate(sDate) Then GetDate = CDate(sDate)
End If
End Function
発注書取込ボタンのクリック時のイベントプロシージャを下記にします。
Private Sub btn_発注書取込_Click()
Dim FileName As String
FileName = getFileName("")
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "T_発注書取込", FileName, True, "発注数$B4:J32"
MsgBox "インポート完了", vbInformation + vbOKOnly
Dim vDate As Variant
vDate = GetDate(FileName)
If IsNull(vDate) Then
MsgBox "ファイル名に日付は含まれてません"
Else
MsgBox "日付は" & Format(vDate,"yyyy/mm/dd"), vbInformation + vbOKOnly
End If
End Sub
上記のフィールドも持つ空のテーブルを作成しておきます。
ID はオートナンバー型の主キーにしておきます。
下記のSQLのクエリを作成します。
SELECT
会社マスター.会社ID,
商品マスター.商品ID,
Choose([商品ID],[商品1],[商品2],[商品3],[商品4]) AS 個数
FROM
T_取込 INNER JOIN 会社マスター ON T_取込.社名 = 会社マスター.社名, 商品マスター
ORDER BY
T_取込.取込ID, 会社マスター.会社ID, 商品マスター.商品ID;
SELECT
会社マスター.社名,
会社マスター.[〒],
会社マスター.住所1,
商品マスター.商品名
FROM
(T_会社別売上 INNER JOIN 会社マスター ON T_会社別売上.会社ID = 会社マスター.会社ID)
INNER JOIN 商品マスター ON T_会社別売上.商品ID = 商品マスター.商品ID
, T_Num
WHERE
T_Num.Num<=[個数]
ORDER BY
T_会社別売上.会社ID, T_会社別売上.商品ID, T_Num.Num;
Set rst = Me.frm注文依頼発注用_一覧Sub.Form.RecordsetClone
rst.Filter = "注文書作成チェック = True AND 発注ナンバー Is NULL"
rst.Sort = "仕入先ID ASC,業務用品ID ASC,単位_注文数"
Set rst = rst.OpenRecordset '←これが必要
rst.MoveFirst
Do Until rst.EOF
'呼び出し例
Private Sub ImportTest1()
Dim strTargetFilePath As String
Dim strTargetSheetName As String
Dim varRet As Variant
strTargetFilePath = "C:\FolderName\BookName.xlsx"
strTargetSheetName = "Sheet1"
varRet = ImportOrderRecords(strTargetFilePath, _
strTargetSheetName)
If IsNull(varRet) = False Then
MsgBox strTargetFilePath & " の " & _
strTargetSheetName & " から " & _
varRet & " 件のレコードを取り込みました。", _
vbInformation, _
"実行完了"
End If
End Sub
Function ImportOrderRecords(SourceBookPath As String, SourceSheetName As String)
On Error GoTo Err_ImportOrderRecords
Const OrderDateCellAddress As String = "B2"
Const OrderDateSuffix As String = "依頼分"
Const HeaderRow As Long = 4
Const KeyColumn As Long = 2
Const DestinationTableName As String = "T_インポートテーブル"
ImportOrderRecords = Null
Dim xlsApp As Object 'Excel.Application
Dim xlsBook As Object 'Excel.Workbook
Dim xlsWorksheet As Object 'Excel.Worksheet
Set xlsApp = CreateObject("Excel.Application")
Set xlsBook = xlsApp.Workbooks.Open(FileName:=SourceBookPath, ReadOnly:=True)
Set xlsWorksheet = xlsBook.Worksheets(SourceSheetName)
Dim varOrderDate As Variant
Dim lngSuffixPostion As Long
With xlsWorksheet.Range(OrderDateCellAddress)
varOrderDate = .Value
lngSuffixPostion = InStrRev(varOrderDate, OrderDateSuffix, -1, vbTextCompare)
If lngSuffixPostion > 0 Then
varOrderDate = Trim(Left(varOrderDate, lngSuffixPostion - 1))
End If
If IsDate(varOrderDate) = True Then
varOrderDate = CDate(varOrderDate)
Else
Debug.Print .Address(False, False) & " セルの値: "
Debug.Print .Value
MsgBox .Address(False, False) & " セルから依頼日を参照できません。", _
vbExclamation, _
"ImportOrderRecords"
Set xlsWorksheet = Nothing
xlsBook.Close False
Set xlsBook = Nothing
xlsApp.Quit
Set xlsApp = Nothing
Exit Function
End If
End With
Dim lngFirstDataRow As Long
Dim lngLastDataRow As Long
With xlsWorksheet
lngFirstDataRow = HeaderRow + 1
lngLastDataRow = .Cells(.Rows.Count, KeyColumn).End(xlUp).Row
If lngFirstDataRow > lngLastDataRow Then
MsgBox "ワークシート[" & .Name & "]からデータ行を参照できません。", _
vbExclamation, _
"データ参照エラー (ImportOrderRecords)"
Set xlsWorksheet = Nothing
xlsBook.Close False
Set xlsBook = Nothing
xlsApp.Quit
Set xlsApp = Nothing
Exit Function
End If
End With
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Set db = CurrentDb
strSQL = "DELETE * FROM [" & DestinationTableName & "]"
Debug.Print strSQL
db.Execute strSQL, dbFailOnError
strSQL = "SELECT * FROM [" & DestinationTableName & "]"
Debug.Print strSQL
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
Dim lngDataRow As Long
Dim lngInsertCount As Long
For lngDataRow = lngFirstDataRow To lngLastDataRow
rs.AddNew
rs![依頼日].Value = varOrderDate
With xlsWorksheet.Cells(lngDataRow, KeyColumn)
rs![社名ID].Value = .Value
rs![商品名1].Value = .Offset(0, 4).Value
rs![商品名2].Value = .Offset(0, 5).Value
rs![商品名3].Value = .Offset(0, 6).Value
rs![商品名4].Value = .Offset(0, 7).Value
End With
rs.Update
lngInsertCount = lngInsertCount + 1
Debug.Print lngInsertCount & " 件目のレコードを取り込みました。"
Next
ImportOrderRecords = lngInsertCount
Exit_ImportOrderRecords:
On Error Resume Next
Set rs = Nothing
Set db = Nothing
Set xlsWorksheet = Nothing
If Not xlsBook Is Nothing Then
xlsBook.Close False
Set xlsBook = Nothing
End If
If Not xlsApp Is Nothing Then
xlsApp.Quit
Set xlsApp = Nothing
End If
Exit Function
Err_ImportOrderRecords:
Dim strErrMsg As String
strErrMsg = Err.Number & ": " & Err.Description
MsgBox strErrMsg, _
vbCritical, _
"実行時エラー (ImportOrderRecords)"
Resume Exit_ImportOrderRecords
End Function
上手い事できました！ありがとうございました
https://www.google.com/search?q=16進数の数字をCSV形式で保存してある物をエクセルで読み込もうとする
テキスト (.txt または .csv) ファイルのインポートまたはエクスポート
16進コードとは「16進ダンプ」のことです。
16進数の数字をCSV形式で保存してある物をエクセルで読み込もうとすると
"Ｅ"が指数表示で読み込まれるので、すぐにわかります。
文字コードは基礎的な事ことなので、最初からチェックしています。
EXCELで不具合が起きるという事は、
マイクロソフト系のソフトを使うと全滅の可能性があるのが怖いです。
まったく原因が分からないので、終了ということでありがとうございました。
ここの
Dateは今日の日付データですね。これのデータ型は「日付型」で、文字列処理に使うと自動的に型変換が行われ、通常、「YYYY/MM/DD」の書式の文字列になります（たとえば「2023/12/27」など）この結果生成される文字列は
のようになります。（[pass]のところは提示がないので適当に読み替えてください）
windowsではファイル名（ファイルパス）に「
/」が使えないのでエラーになりますこのため、ファイル名として使うためには自前で変換処理を入れる必要があります
ということならば、Format関数で書式を設定すると良いでしょう
お世話になります。
本日改めて試したら問題なく更新できました・・・？？
上手くいかなかった時は、更新しても何も起こらなかったり、備考フィールドが全て喪中に更新されたりと
謎の現象が起こっていました。
とりあえず私が耄碌したのではなさそうでよかったです。(笑)
お騒がせ致しました。
備考フィールドのデータ型は何でしょうか？ 本当は何文字ぐらい入っていますか？
SQL自体には問題なさそうです。
うまくいかないとかは、具体的にどのようにうまくいかないのですか。
エラーがでるならそのエラーメッセージを提示してください。
期待の結果にならないのなら、どのような結果になるのか提示ください。
ご連絡ありがとうございます。
やはり対応を待つしかないのですね。。。
色々とありがとうございました！
無事に出来ました。
この度は有り難うございました。
アップデートの弊害だったようですね。
https://cafebreak.hatenablog.com/entry/2023/10/27/075433
アンインストールできないとのことなので、対応を待つしかなさそうですね。
Backup機能を使っている場合はアップデート前に戻す、やどうしてもすぐに改善する必要がある場合はOSを入れ直すのも手っ取り早いかもしれません。
ご連絡ありがとうございます。
再起動や、Officeの修復等行いましたが、改善されませんでした。
Win11のKB5030310適用後、Excelでもコピペでエラーがでるとのサイトを発見しました。
https://answers.microsoft.com/ja-jp/msoffice/forum/all/windows11-kb5030310適用後/8b5c1ebe-312b-4d47-aaf5-7726ae1a1957
時期的にも同じくらいの時期なので、OSの更新プログラムが原因かもしれませんが、
そのプログラムは、すでにアンインストール一覧になく、削除もできません。
リンクテーブルを削除して再作成するようにしました。
なるほどですね。
確認してみると、貼り付けを行いたい場所を選択せずにダブルクリックすると同様のメッセージがでます。
コピーしたい場所をクリックしてからダブルクリックしてはどうでしょうか。
それでも発生する場合は一度OSを再起動でしょうか・・・。
どのOffice（Access、EXCEL他）でも発生する場合は、一度Officeの修復をされてみるのも良いかと思います。
返信ありがとうございます。
VBAではなく、Officeクリップボードを使用した際の不具合です。
https://support.microsoft.com/ja-jp/office/office-クリップボードを使用したコピー-貼り付け-714a72af-1ad4-450f-8708-c2931e73ec8a
個別にレスできずすみません。
回答ありがとうございます。
意味を理解しながら一つずつ試してみたいと思います！
過去に似た感じの質問があるようです。
なにか貼り付けの条件を満たしていないようですね。
https://zawazawa.jp/ms-access/topic/394
またこちらも類似の内容です。
https://hamachan.info/win8/access/mukou.html
一般機能のパラメータクエリで可能です
SQLの例：
正規表現によるパターンパッチングを行う場合。
getFileNameがget file nameっぽくないですねぇC:\(データ)\ABC(2023.12.12).xlsとか試してみるといいと思います
先にファイル名を取り出しておくでもいいですが、InStr関数ではなくInStrRev関数を使っておくとより良いと思います
ついでにmidを使わない方法を考えてみたり
手抜きしているので
C:\データ\ABC)2023.12.12(.xlsも日付を拾ってきます標準モジュールに下記の関数を作成します。
発注書取込ボタンのクリック時のイベントプロシージャを下記にします。
取得した日付はとりあえずメッセージボックスに表示してますが、
使用用途に合わせて修正してください。
すみません、自己レスです。
ただ16進数しただけだと考えられます。
検索で見つかる事例で10進と16進が一致しないものもありましたが、
それは転記ミスだと思われました。
お騒がせしました。
Accessにもあるみたいですね（使ったことはないですが）
https://kabudata-dll.com/ms-access/chart/
自己レスです。
個人的にこれまで考えたことが無かったのですが、こちらの記事が普通に参考になりました。
https://sourcedaddy.com/ms-access/understanding-module-load-demand.html
ちなみに AutoExec したところ、
私が作っていた小さなモジュール30程度は全て「開かれて」立ち上がりました。
巨大なモジュールが多数あれば、Access が選別するのかもしれません。
お世話になっております。
意図した通りの出力結果が出るようになりました！ありがとうございました
何がどのように繋がって出力結果にたどり着いたのか、クエリやテーブルの構造・関数などを確認し勉強させて頂きます！
ありがとうございます！
正規化されたテーブルを作るところからやってみます！
My Car Bomberさんの質問から発生する一連の構築に関する回答は、DBを使ったシステムのスタンダードかつお手本のような内容で素晴らしいですね。
出来上がればDBの速度低下で悩まされることも無く、カスタマイズもし易いシステムになりそうです。
まずは「T_取込」テーブルを正規化されたテーブルに変換します。
正規形のテーブルは記のようになります。
T_会社別売上 (テーブル名は適当ですので実態にあったものに変更してください。)
上記のフィールドも持つ空のテーブルを作成しておきます。
ID はオートナンバー型の主キーにしておきます。
下記のSQLのクエリを作成します。
これを保存してデータシートビューで希望のデータになっていることを確認したら、
追加クエリに変更して追加先を「T_会社別売上」テーブルにします。
この追加クエリを実行するとT_会社別売上に上記のデータ例のようにデータが追加されます。
下記のような数値型フィールドが一つのテーブルを作成します。
予想される最大個数までの連番を入力しておきます。
T_Num
下記のようなSQLのクエリを作成すればレポート出力用にデータになります。
これをレポートのレコードソースに設定すればいいでしょう。
hatena様
ご回答ありがとうございます。
ご指摘の通りやってみましたら、バッチリできました。
Set rst = rst.OpenRecordset で再設定しないといけない事を初めて知ったので勉強させてもらいました。
ありがとうございました！
助かりました。
DAOのRecordsetは、FilterプロパティやSortプロパティを設定したあと、再度開きなおさないと反映されません。
また、Nullは=演算子ではなくIs演算子で判定します。
大変参考になります、コードの内容理解に私では少し時間がかかりそうですが、読み解いてみます！
お返事遅くなりまして申し訳ございません。
こちらでできました。
作成日 > min(作成日)ですか、なるほどです。
どうもありがとうございます。
補足:
事前バインディングではなく実行時バインディングを採用される場合は、Excel.XlDirection 列挙のメンバー定数 xlUp の代わりに値 -4162 を渡すようにして下さい。
といった処理を実行したいなら以上のようなコードになるでしょう。
ただ、前回のスレッドにおいて
とご説明された通りなのであれば、正規化したテーブルに変換し、互いの[商品ID]同士で[商品マスター]と結合できるようにされた方がよいでしょう。
データ集計を行う上でも「発送用のレポート」を出力する上でも、その方が便利なのは明らかです。
エクセルの方は変更できないということであれば、アクセスにインポートしてから、アクセスの方で正規化変換することになります。
Accessではレポートに出力するだけで、出力レイアウトがエクセルの表とほぼ同じということなら必要ないです。
ただ、せっかくアクセスにインポートするならデータベースとして活用したいですよね。
印刷だけなら、エクセルでもできますので。
シートの範囲指定してインポートするなら、TransferSpreadsheet で第6引数でシートや範囲を指定できます。
上記はB列からI列の４行目からデータのある最後までインポートします。
シートの形式を変更したり、シートを手作業で加工して名前を付けたりすることは出来ないという前提でお願いします。
そのため、任意の範囲のみをインポートする方法を模索しています。
正規化というのは、今回でいえば、A列と1～3行目が無ければ正規化できているということになりますか？
エクセルの表のフォーマットがデータベースとしては扱いにくい形になってます。
データベース用語とて「正規化」ができていない状態です。
もし、エクセルの表の形式を変更できるならそれを検討してみてはどうでしょう。
banjoさんの回答も同じ意味だと思います。
もし、エクセルの表のフォーマットは変更不可ということなら、
表範囲に名前をつけることはできないでしょうか。
表範囲をテーブルにできないでしょうか。
(テーブルにすれば自動で名前がつきます。)
そうすれば、インポートするときにその名前を指定してインポートできます。