AccessVBA フィールド内の数値のみを取り出して編集する
例えば、IDやコードNoなどで、「01234-0」や「A01234」といったように
数値と文字や記号混じりの文字列から、「数値」のみ を取り出して編集したい場合などで使えるコードです。
サンプルコードでは、[テーブル名]というテーブル内にあるIDフィールドから数値のみを取り出して、ID2フィールドに格納するというものです。
サンプルコードを変形すれば、反対に文字のみを取り出すことも可能です。
以下、VBAの記述
'--------------------------------------------------------------------------------------------------
Dim db As Database
Dim rst As Recordset
Dim i As Integer
Dim strId As String
Dim nameLen As Integer
Set db = CurrentDb
Set rst = db.OpenRecordset("テーブル名")
If rst.RecordCount <> 0 Then
Do Until rst.EOF
rst.Edit
'取り出した数値を格納する変数の初期値
strId = ""
i = 1
'IDフィールドの文字数をカウント
nameLen = Len(rst!ID)
'IDフィールドを左から1文字ずつ数値かどうかを判定
For i = 1 To nameLen
If Mid(rst!ID, i, 1) Like "[0-9]" Then
’取り出した数値を左から順に1文字ずつ変数に加える
strId = strId & Mid(rst!ID, i, 1)
End If
Next i
'変数に格納されたIDフィールドの数値部分をID2フィールドに格納
if Len(strID) > 0 then
rst!ID2 = CDbl(strId)
else
rst!ID2 = 0
end if
rst.Update
rst.MoveNext
Loop
db.Close
Set db = Nothing
End If
'---------------------------------------------------------------------------------------------
以上、VBA終わり。
上記は単純に数値のみを抽出するものですが、取り出したIDに何らかの加工して、ID2フィールドに格納するタイプを作成した事もありました。
例えば、取り出した数値が9の場合は0、それ以外は取り出した数値に1を足すみたいなケースです。
その場合は、上記のFor〜Next内を以下のように変形して作成しました。
以下、VBA付記。
'--------------------------------------------------------------------------------------------
For i = 1 To nameLen
If Mid(rst!ID, i, 1) Like "[0-9]" Then
Dim IDnumber As Integer
IDnumber = Clng(Mid(rst!ID,i,1))
'取り出した数値をSelect〜End Selctで条件分岐
Select Case IDnumber
Case Is = 9
strId = strID & "0"
Case Else
StrId = strID & (IDnumber +1)
End Select
End If
Next i
'--------------------------------------------------------------------------------------------------
以上、付記終わり。
AccessVBA テーブル内のフィールド名を検索して処理
テーブル内に同じカテゴリーのフィールドが複数ある場合があります。
例えば、氏名1、氏名2、氏名3 といったようにフィールド名の末尾に数字をつけて登録しているようなケースです。
このようなケースで、同じカテゴリーのフィールドに同一の処理を行う場合のコード描いて見ました。
サンプルコードでは、テーブル名というテーブル内に氏名1〜5までフィールドがあり、
そのフィールドに登録がある人数をカウントし、人数フィールドに代入するというものです。
以下、VBAの記述。
'---------------------------------------------------------------------------------------------
Function countFld
Dim db As Database
Dim rst As Recordset
Dim strSQL As String
Dim i As Integer '同じカテゴリー末尾の数値
Dim cnt As Integer
Dim fldName As String
Set db = CurrentDb
strSQL = "SELECT*FROM [テーブル名];"
Set rst = db.OpenRecordset(strSQL, dbOpenDynaset)
’処理対象のフィールド名
fldName = "氏名"
i = 0 '初期値
cnt = 0
Do Until rst.EOF
rst.Edit
For i = 1 To 5 'フィールド名末尾の数値1〜5までForで繰り返し
’rst(fldName & i)で対象フィールド名を定義
’Null及び空文字フィールド以外をカウント
If Not IsNull(rst(fldName & i)) And Len(Trim(rst(fldName & i))) > 0 Then
cnt = cnt + 1
End If
Next i
'カウントした結果を代入するフィールド
rst!人数 = cnt
cnt = 0
rst.Update
rst.MoveNext
Loop
db.Close
Set db = Nothing
End Function
'---------------------------------------------------------------------------------------------------
以上、VBAの記述終わり。
TableDefs オブジェクトを使ってもイケそうな気がしていますので、それはまた別の機会に書いてみたいと思います。
AccessVBA 常に直近◯ヶ月のデータを自動で抽出する設定を行う
日付の入ったテーブルから、その日付を元に例えば直近３ヶ月間など常に一定期間のデータを抽出したい場合があります。
フォーム画面で抽出期間を設定し、コマンドクリック時に抽出することも可能ですが、常に一定期間の場合、手動で期間を設定する手間を省くことができます。
以下、VBAの記述
'-----------------------------------------------------------------------------------------
'サンプルコードでは[元データ]というテーブルから[抽出データ]というテーブルに本日を起算日として直近3ヶ月のデータを抽出する設定です
Function selectData
Dim db As Database
Dim rst As Recordset
Dim rst1 As Recordset
Dim strSQL As String
Dim cntMon As Integer '基準日=本日の月
Dim startYear As Integer '開始日の年部分
Dim startMon As Integer '開始日の月部分
Dim startDay As Date '自動で設定する開始日
Dim endDay As Date '自動で設定する終了日
'今月を抽出
cntMon = Month(Date())
'今月が何月かによって処理を分岐させる-----直近3ヶ月なので以下の通り
’開始日ば昨年にずれる場合の開始月 = 基準月（今月）+12 - 抽出期間（3ヶ月)
Select case cntMon
Case Is < 4
startMon = cntMon + 9
startYear = Year(Date())-1
Case Else
startMon = cntMon - 3
startYear = Year(Date())
End Select
'例えば本日が2017年3月4日だとすると開始日（startDay)は2016年12月1日、終了日(endDay)は、2017年3月1日となります
startDay = DateSerial(startYear,startMon,1)
endDay = DateSerial(Year(Date()),Month(Date()),1)
Docmd.RunSQL "DELETE*FROM [抽出データ];"
Set db = CurrentDb
’開始日は等号で含めて終了日は不等号で含めない
strSQL = "SELECT [元データ].* FROM [元データ] "
strSQL = strSQL & "WHERE [元データ].日付 >= #" & startDay & "# "
strSQL = strSQL & "AND [元データ].日付 < #" & endDay & "#;"
Set rst1 = Db.OpenRecordSet(strSQL,dbOpenSnapshot)
Set rst = Db.OpenRecordSet("[抽出データ]")
If rst1.RecordCount <> 0 then
rst1.Movefirst
Do until rst1.EOF
rst.Addnew
'追加処理
rst.Update
rst1.Movenext
Loop
db.Close
Set db = Nothing
End if
End Function
'----------------------------------------------------------------------------------------------
以上、VBA記述終わり。
AccessVBA 自身のファイルサイズを取得し処理をストップさせる
アクセスのファイル容量が2GBを超えるとファイルが破損してしまいます。
大容量のデータをインポート実行後、或いは大容量のデータ処理を行なった直後など、一時的にファイル容量が大きくなってしまいます。
ファイルを閉じる際に最適化をするにチェックを入れていても、閉じる前に気づかずに他の処理を実行してしまうとファイルが破損するトラブルに見舞われてしまいます。
そこでファイルに負荷がかかりそうな処理の実行前後にファイルサイズを取得して、一定限度の容量を超えた場合、処理を中断して最適化を促すようなメッセージを入れたいと思いました。
以下、VBAの記述
'------------------------------------------------------------------------------------------------
Dim strPath As String Dim fileSize As Long strPath = CurrentProject.FullName fileSize = FileLen(strPath)
'ファイルサイズはバイト単位なので、以下の例ですと1GB If fileSize > 999999999 Then MsgBox "ファイル容量が大きくなっています。一旦ファイルを閉じて再起動してから、再度集計実行してください。"
Exit Sub Else End If
'-----------------------------------------------------------------------------------------------------------------------------
VBAの記述終わり。
※参考サイト
自分自身のMDBファイルサイズを取得 --Access Club 初級者 Forum--
AccseeVBA Excelエクスポート 決まったファイル名で上書き保存する
AccessからエクスポートしたEXCELファイルが何のファイルだったか分からなくなってしまうのを避けるため、毎回決まったファイル名（一定のルールのもとで作成されたファイル名）をエクスポートする仕様を作ってみました。
繰返し同じ処理を行う可能性を考慮して、既に同じファイル名のEXCELファイルを作成している場合には上書き保存し、ない場合には新規で作成します。
既に同じファイル名のEXCELファイルを作成している場合、ファイルを開いていると上書き保存できないので、EXCELファイルを開いているかどうかのチェックを含めています。
※EXCELファイルが開いているかチェックするためのコード参考サイト
ACCESSからExcelファイルが開いているか調べる | SugiBlog
以下、VBAの記述。
'------------------------------------------------------------------------------------------
Function transferXlsData
Dim db As Database
Dim rst As Recordset
Dim strSQL As String
Dim filename As String 'エクスポートするフルパスのファイル名
Dim filename1 As String '抽出期間を定義するためのサブネーム
Dim rc As Integer
Set db = CurrentDb
strSQL = "SELECT MIN([テーブル名].[日付]) AS 開始日, MAX([テーブル名].[日付]) AS 終了日 FROM [テーブル名];"
Set rst = db.OpenRecordset(strSQL,dbOpenSnapshot)
If Dcount("*","テーブル名") = 0 then
MsgBox "エクスポートするデータがありません。"
Exit Sub
End If
'抽出データの日付開始＆終了をファイル名の一部としている
filename1 = Format(rst!開始日,"yyyymmdd") & "_" & Format(rst!終了日,"mmdd")
’Accessファイルと同じフォルダへのエクスポート
filename = CurrentProject.Path & "¥エクセル出力データ_" & filename1 & ".xlsx"
If Dir(filename, vbDirectory) <> "" Then
Dim xlsApp As Object
Dim xlsbook As Object
Set xlsApp = CreateObject("Excel.Application")
Set xlsbook = xlsApp.Workbooks.Open(filename)
If xlsbook.readonly Then
MsgBox "エクセル出力データ_" & filename1 & "という名前のエクセルファイルが開いています。" & vbCrLf & _
"このファイルを上書きするので、一旦ファイルを閉じるか、開いているファイルを別の名前で保存して終了してください。"
xlsbook.Close
xlsApp.Application.Quit
Set xlsbook = Nothing
Set xlsApp = Nothing
Exit Sub
End If
xlsbook.Close
xlsApp.Application.Quit
Set xlsbook = Nothing
Set xlsApp = Nothing
'既に保存されているEXCELファイルを一旦削除する
Kill filename
End If
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12xml, "[テーブル名]",filname,"エクセル出力データ_" & filename1",1
rc = Dcount("*","テーブル名")
MsgBox rc & "レコードのデータをこのファイルと同じフォルダに出力しました。" & vbcrlf & _
"出力ファイル名：エクセル出力データ_" & filename1 & ".xlsx"
End Function
'---------------------------------------------------------------------------------------------------
以上、VBA記述終わり。
出力するフォルダ名を指定した方がいいかなと思いますが、フォルダ指定するのに1工程入ってしまうので、個人的にはAccessと同じフォルダへの自働出力を重宝しています。
※フォルダ名を指定する場合の参考サイト
AccessVBA Access2010のナビゲーションウィンドウ・クイックアクセスバーの表示切り替え
Access2000（.mdb）ファイルの場合には、Shift+Enter起動に制限をかけることで、
テーブルなどのファイル内容閲覧に制限をかけることができます。
※参考サイト
上記サイトを参考にAccess2000ではデータベースウィンドウを非表示にすることができました。
自分の設定に落ち度があったせいか、
Access2010ではナビゲーションウィンドウ、クイックサクセスバーの非表示ができず、色々サイト検索しながら、以下の方法にたどり着きました。
以下、VBAの記述
'----------------------------------------------------------------------------------------------
'非表示にする場合
Function hideNavigationWindow
Dim db as database
Dim tbl1 as TabelDef '非表示にしておきたいテーブル
'ナビゲーションウィンドウの非表示
DoCmd.NavigateTO "acNavigationCategoryObjectType",""
DoCmd.RunCommand acCmdWindowHide
'クイックアクセスバーの非表示
Docmd.ShowToolbar "Ribbon",acToolbarNo
'テーブルの非表示
Set db = CurrentDb
Set tbl1 =db.TableDefs("テーブル名")
tbl1.Attributes = 1 '非表示=1, 表示=0
db.Close
Set db = Nothing
End Function
hideNavigationWindow をForm_Load時に呼ぶことによって起動時に非表示にすることができました。
反対にメンテナンスなどで表示させたい時には以下の通り。
'************************************************************************************************************
'再表示する場合
Function showNavigationWindow
Dim db as database
Dim tbl1 as TabelDef '非表示にしておいたテーブル
’ナビゲーションウィンドウの表示
DoCmd.NavigateTo "acNavigationCategoryObjectType",""
DoCmd.SelectObject acForm,"",True
'クイックアクセスバーの表示
Docmd.ShowToolbar "Ribbon",acToobarYes
'テーブルの表示
Set db = CurrentDb
Set tbl1 = db.TableDefs("テーブル名")
tbl1.Attributes = 0
db.Close
Set db = Nothing
End Function
'-------------------------------------------------------------------------------------------
以上、VBAの記述終わり。
再表示する場合には、フォームにパスワード入力欄を作って、
Enter キーを実行後、パスワードがあっていた場合に呼ぶようにして対応。
加えて、上記コードを記述した標準モジュールそのものをパスワードロックかけて完成としました。
今回は他のファイルからマスタ類を取り込んで、処理後に取り込んだマスタ類を削除する仕様にしており、上記ロックを設定したファイルそのものにはマスタ、データが最小限しか残っていないので、細かくロック自体の完成度の検証は軽くしか行なっていませんが、行けそうな気がしています。
※参考※標準モジュールのパスワード設定方法
■T'sWare Access Tips #610 〜VBAのモジュールにパスワードを設定するには？〜
AccessVBA 元データにグループ毎の集計結果（演算結果）を挿入する（配列変数）
元データのグループごとの合計値を元データに挿入する。
大量レコードを処理する場合は動作が遅くなるようだが（1000〜2000レコードくらいまで？）、配列変数を使って作成してみる。
＜元データ＞
値が全て0になっている総数のフィールドに商品ごとの合計値を挿入する
＜完成後のイメージ＞
商品ごとの合計値が総数フィールドに追加された。
以下、VBAの記述。
'----------------------------------------------------------------------------------------
’下段のFunction createTotalCount プロシージャから呼ばれる
’配列変数とレコード数を返す
'配列数は未定のため、()で記載
Private Sub createArray(varArray() As Variant, cnt As Integer)
Dim db As Database
Dim rst As Recordset
Dim strSQL As String
Dim i As Integer
Set db = CurrentDb
’グループごとの合計値をSQLで算出する
strSQL = "SELECT originTbl.商品, Sum(originTbl.数量) AS 総数 FROM originTbl "
strSQL = strSQL & "GROUP BY originTbl.商品;"
Set rst = db.OpenRecordset(strSQL, dbOpenSnapshot)
If rst.EOF Then
cnt = -1
Exit Sub
End If
rst.MoveLast
'一次元の配列数を抽出
cnt = rst.RecordCount
rst.MoveFirst
'配列の次元ごとの配列数は設定する必要がある
ReDim varArray(cnt, 1) As Variant
i = 0
Do Until rst.EOF
varArray(i, 0) = rst!商品
varArray(i, 1) = rst!総数
i = i + 1
rst.MoveNext
Loop
rst.Close
db.Close
Set db = Nothing
End Sub
'合計値を挿入するメインのプロシージャ
Public Function createTotalcnt()
Dim db As Database
Dim rst As Recordset
Dim varArray() As Variant
Dim cnt As Integer
Dim strSQL As String
Dim i As Integer
'グループごとの合計値を格納する配列変数作成へ
’戻り値は配列と一次元の配列数（レコード数）
Call createArray(varArray(), cnt)
If cnt = -1 Then
Exit Function
End If
Set db = CurrentDb
strSQL = "SELECT originTbl.* FROM originTbl;"
Set rst = db.OpenRecordset(strSQL, dbOpenDynaset)
Do Until rst.EOF
rst.Edit
’配列変数のKeyCodeと一致する場合、総数フィールドに値を挿入
’配列数までFor〜Nextで繰り返し処理
For i = 0 To cnt
If rst!商品 = varArray(i, 0) Then
rst!総数 = varArray(i, 1)
Exit For
End If
Next i
rst.Update
rst.MoveNext
Loop
rst.Close
db.Close
Set db = Nothing
End Function
'-------------------------------------------------------------------------------------
以上、VBA終わり。
