Sub AdoOpen(FileName As String, adoCn As ADODB.Connection)
Dim FilePath As String
FilePath = "C:\Users\tasukaru\Desktop\VBA\出品データ用\access\" & FileName
Set adoCn = CreateObject("ADODB.Connection") 'ADODBコネクションオブジェクトを作成
adoCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FilePath & ";" 'Accessファイルに接続
End Sub
Function AddDB(ByVal Tn As String, ByVal Fn As String, ByVal Fd As String, ByRef adoCn As ADODB.Connection) As Boolean
Dim strSQL As String
AddDB = True
On Error GoTo errTrap
strSQL = "INSERT " & "INTO " & Tn & Fn & " VALUES" & "(" & Fd & ")"
'Debug.Print strSQL
adoCn.Execute strSQL 'SQLを実行して対象を追加
Exit Function
errTrap:
AddDB = False
MsgBox Err.Number & ": " & Err.Description
End Function
Public Sub Proc()
Dim adoCn As ADODB.Connection
AdoOpen "データ.accdb", adoCn
Tn = "・・・"
Fn = "・・・"
Fd = "・・・"
If AddDB(Tn, Fn, Fd, adoCn) = False Then
MsgBox "データ追加に失敗しました。"
End If
adoCn.Close
Set adoCn = Nothing
End Sub
Sub AdoOpen()
strFileName = "データ.accdb" 'データベースのファイル名
Set adoCn = CreateObject("ADODB.Connection") 'ADODBコネクションオブジェクトを作成
adoCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\tasukaru\Desktop\VBA\出品データ用\access\" & strFileName & ";" 'Accessファイルに接続
End Sub
Worksheets("出品ファイル").Activate
For i = 2 To nl
で、データを拾っていきます。
この過程で、画像をコピーしたり、フォルダを作ったりという作業を並行して行っているので
先走りして、追加が終わらないうちに、次のデータの処理を始めてしまうのが、原因だろうと予想しております。
Declare PtrSafe Function GetInputState Lib "USER32" () As Long
と
SyuppinData (i)
If GetInputState() Then DoEvents
で、先走りしないようにはしていますが、
経験上、あまり効果は見込めません。
Public Function 許可日(申請日 As Variant) As Variant
Dim 営業日 As Long
許可日 = 申請日
If IsNull(許可日) Then Exit Function
Do
許可日 = 許可日 + 1
Select Case Weekday(許可日)
Case vbMonday To vbFriday
If IsNull(DLookup("祝日名", "T_祝日", "日付=#" & 許可日 & "#")) Then
営業日 = 営業日 + 1
End If
End Select
Loop Until 営業日 = 2
End Function
活用させて頂いているAutoFontSizeプログラム
Public Sub AutoFontSize(Ctr As Control, IniFontSize As Integer)
Const MinFontSize = 4 '最小のフォントサイズ
Const d = 53 'うまく収まらずに改行されてしまう場合はここの数値を増やす
Dim rpt As Report, Str As String, W As Long
Dim arStr, i As Integer, H As Long
Set rpt = CodeContextObject
With rpt
If Ctr.ControlType = acTextBox Then
Str = Nz(Ctr.Value, "") 'ここでエラーが出る場合は、Str = Nz(Ctr.Value,"")
ElseIf Ctr.ControlType = acLabel Then
Str = Ctr.Caption
Else
Exit Sub
End If
If Str = "" Then Exit Sub
.FontName = Ctr.FontName
Public Function 許可日(申請日 As Date) As Date
Dim 営業日 As Long
許可日 = 申請日
Do
許可日 = 許可日 + 1
Select Case Weekday(許可日)
Case vbMonday To vbFriday
If IsNull(DLookup("祝日名", "T_祝日", "日付=#" & 許可日 & "#")) Then
営業日 = 営業日 + 1
End If
End Select
Loop Until 営業日 = 2
End Function
２つのテーブルの検索結果をどのように表示したいのでしょうか。
現状は２つのフォームに表示されているようですが、それを一つのフォームで表示したいということでしょうか。
その場合は、２つのテーブルデータを、一つの表として表示したいのか、２つの表として並べて表示たいのか、
とか、いろいろ表示の仕方がありますが、どのような表示がご希望でしょうか。
まずは、それを明確にしてください。
貴重な情報ありがとうございます。
参考にさせていただきます。
それに関しては、深い意味はないです。他から呼び出す必要がないなら、Private で問題ないです。
というか、AdoOpen AddDB を汎用化して、他で使いまわすなら、こちらの方を標準モジュールでPublicにしておいた方がいいですね。
なんとなく、でも確実にわかってきました。
If AddDB(Tn, Fn, Fd, adoCn) なんですね。
ありがとうございます。
なぜ、他のモジュールから呼び出せるPublicなのか、
分からないので調べてみます。
どうしても、謎だったら明日、質問させていただきます。
私のコードの Sub Proc が Sub Data に相当しますので、参考にしてください。
すみません、下の部分が分かりません
下の2つのプロシージャは、Sub Dataから呼び出すことになると思いますが
adoCnは、どう定義して呼び出したらよいのでしょうか？
Sub AdoOpen(FileName As String, adoCn As ADODB.Connection)
Function AddDB(ByVal Tn As String, ByVal Fn As String, ByVal Fd As String, ByRef adoCn As ADODB.Connection) As Boolean
最初の、Function AddDBの中に、Sub Dataのコードを書いて処理すれば
コネクションを1回だけ開いて、連続してアップできますが、
分けた方が、汎用性のあるコードになるので、使えるようにしたいと思います。
ちなみに、
別案として、acDialog でダイアログモードで開いたときに、APIで無理やりサイズ変更可能にする方法もあります。
下記でその方法を使ってますのでご参考に。
纏めると、方法としては、
メインフォーム「ポップアップ」「いいえ」
子フォーム、孫フォーム「ポップアップ」「はい」
メインフォーム「ポップアップ」「はい」
子フォーム、孫フォーム「ポップアップ」「はい」、「作業ウィンドウ固定」「はい」
メインフォーム「ポップアップ」「はい」
子フォーム、孫フォーム ダイアログモード(acDialog)で開く、APIでサイズ変更可能にする
のいずれかになると思います。
それぞれ、動作が異なりますので、動作を確認して、最適な方法を選択してください。
「作業ウィンドウ固定」を「はい」ですか。ありがとうございます。
メインフォームのポップアッププロパティも「はい」です。
訂正します。
稀に隠れてしまう場合がありますので、
明示的に前面表示にするコーディングをしたいと思ってきます。
メインフォームの「ボップアップ」は「いいえ」になってますか。
メインフォームの「ボップアップ」を「はい」にしたまま、
子フォームがメインフォームの裏に隠れないようにするには、子フォームの「作業ウィンドウ固定」を「はい」にしてください。
ありがとうございます。
子、孫ファームのポップアッププロパティは、「はい」にしております。
そうしていても、メインフォームの裏にかくれてしまいます。
子フォーム、孫フォームの「ポップアップ」プロパティを「はい」に設定するのではだめですか。
AdoOpen() というようにプロシージャを分けるなら、下記のような設計がいいかな。
AddDBでデータ追加に失敗するとエラートラップでエラーメッセージを表示するようにしてますので、
それで失敗の原因が特定できると思います。
コードの詳細をアップするのは、連絡をお待ちしてからにしますが、
シートを変数に、格納してそれを対象にするように変更します。
かなり、改善されるような気がします。
あと、初歩的な質問で申し訳ないのですが、
コネクションを最初に1回生成してOpenして、
続けて100回追加して、最後にCloseするには、以下のようなプロシージャを作っておいて
Sub AdoOpen()
strFileName = "データ.accdb" 'データベースのファイル名
Set adoCn = CreateObject("ADODB.Connection") 'ADODBコネクションオブジェクトを作成
adoCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\tasukaru\Desktop\VBA\出品データ用\access\" & strFileName & ";" 'Accessファイルに接続
End Sub
AdoOpen
Set ws = ThisWorkbook.Worksheets("出品ファイル")
Num1 = 1 '回数入力
Num2 = ws.Cells(i, 6).Value '特価取得
・・・
adoCn.Close
で、良いのでしょうか？
[初期のデータ追加]フラグを用意して
＜最終行に追加＞＜計算列オートフィル＞
if [初期のデータ追加] then 最初のデータ行目を削除
とかやればワークテーブルも関数の復元もいらないんじゃないですかね
この部分だけでも、かなりの量になりますが、大丈夫でしょうか？
添付ファイルで送れれば、ファイルを送りますが。
見ていただいて、問題個所を公開していただいても構いません。
この
For Next内でDataプロシージャをCallしているということでよすね。この
For Next内で何をしているか知りたいのです。というのは、
まずはその予想があっているのかどうか、
VBAはシングルタスクなのでVBAの標準のコマンドならそのようなことは通常はおこらないはず、外部コマンドを使っているか、なにか特別なことをしているのか、
その辺を確認したいのです。
追加に失敗したら、追加されるまで処理を繰り返すというのは対症療法的な解決法です。できれば、根本の原因を特定して、そちらで解決できる方法がないかさぐるのが先決だと考えます。
その解決法がどうしてもないのなら、次善策として対症療法的解決法をとるというようにすべきと考えます。
とりあえず現状のコードで修正したほうかいいと思われるところを指摘しておきます。
シートをActivateしてアクティブなシートを対象に処理をしていますが、アクティブシートを前提にするとバグのもとになります。
シートを変数に格納してそれを対象にするか、With ステートメントで明示的に対象シートを指定するほうが確実、安全なコードになります。
次に、下記のコードについて
Functionの戻り値を Recordset にしてますが、
INSERT INTO文は Recordset を返しません。テーブルへのデータを追加するだけです。Function内で戻り値も設定していないので無意味なものになっています。
また、この関数内で、
Set adoCn = CreateObject("ADODB.Connection")とADODBコネクションを生成してますが、
Closeしてません。使用後は明示的にCloseすべきです。
さらに、100件くらいのレコードを追加する場合、
100回ADODBコネクションを生成することになりますが、
無駄なことです。
100件のレコードを追加するなら、コネクションを最初に1回生成してOpenして、
続けて100回追加して、最後にCloseするという処理にすると効率的です。
いや、違うのです。
販売データを作る、EXCELL VBAの専用エディタがあるのですが、
販売待ちのデータは、excellのシートに保存してあります。
多くても、300件以上になることはありません。
そこで、状況を見ながら数量指定(nl)をして、本番のデータに変換して販売を開始します。
Worksheets("出品ファイル").Activate
For i = 2 To nl
で、データを拾っていきます。
この過程で、画像をコピーしたり、フォルダを作ったりという作業を並行して行っているので
先走りして、追加が終わらないうちに、次のデータの処理を始めてしまうのが、原因だろうと予想しております。
Declare PtrSafe Function GetInputState Lib "USER32" () As Long
と
SyuppinData (i)
If GetInputState() Then DoEvents
で、先走りしないようにはしていますが、
経験上、あまり効果は見込めません。
とりあえず、追加の工程は、For iを別口で作って最初に処理するようにはしました。
EXCELLからACCESSは、思っていた以上に負担がかかっているようなので
処理結果を確認して、正しく処理できるまで続けるコードは利用したいと思っております。
提示の
Dataプロシージャは1件のレコードを追加するコードですね。100件のレコードの追加は、
Dataプロシージャをループで呼び出しているのだと思いますが、そのコードも提示してもらえますか。
※質問は編集できますので、質問に追記してください。
連絡が遅くなりすみません。
上記のようにやったらできました。本当にありがとうございました。
伝票ID=1を加えただけでできるとはびっくりです。
このたびはお時間をとらせて申し訳ありませんでした。
おかげさまで完璧でございます。
大変有り難うございました。
Function 許可日 が原因の可能性があります。
下記ように変更してください。
活用させて頂いているAutoFontSizeプログラム
Public Sub AutoFontSize(Ctr As Control, IniFontSize As Integer)
Const MinFontSize = 4 '最小のフォントサイズ
Const d = 53 'うまく収まらずに改行されてしまう場合はここの数値を増やす
Dim rpt As Report, Str As String, W As Long
Dim arStr, i As Integer, H As Long
Set rpt = CodeContextObject
With rpt
If Ctr.ControlType = acTextBox Then
Str = Nz(Ctr.Value, "") 'ここでエラーが出る場合は、Str = Nz(Ctr.Value,"")
ElseIf Ctr.ControlType = acLabel Then
Str = Ctr.Caption
Else
Exit Sub
End If
If Str = "" Then Exit Sub
.FontName = Ctr.FontName
お世話になります。
AutoFontSizeには大変重宝しており感謝申し上げます。
ところで下記項目を縮小で対応しており
この中で出来日を縮小から外せばクレームはないようです。
当面出来日は縮小から外しても支障はありませんので
外して対応しようかと思います。
Private Sub 詳細_Format(Cancel As Integer, FormatCount As Integer)
AutoFontSize Me.支店名, 10
AutoFontSize Me.販社本部, 10
AutoFontSize Me.備考, 10
AutoFontSize Me.申請者, 10
AutoFontSize Me.支店名, 10
AutoFontSize Me.登録予定日, 10
AutoFontSize Me.出来日, 10
AutoFontSize Me.管轄署, 10
End Sub
出来日は申請日と下記のように関連していますので、このあたりに
関係しているのかなと素人考えではありますが。
でもご教示頂いたもので充分でございますので感謝申し上げます。
Public Function 許可日(申請日 As Date) As Date
Dim 営業日 As Long
許可日 = 申請日
Do
許可日 = 許可日 + 1
Select Case Weekday(許可日)
Case vbMonday To vbFriday
If IsNull(DLookup("祝日名", "T_祝日", "日付=#" & 許可日 & "#")) Then
営業日 = 営業日 + 1
End If
End Select
Loop Until 営業日 = 2
End Function
クエリーで 出来日:許可日（[申請日]）
の部分を、下記に変更してください。
早速の回答ありがとうございます。
参考の記事を確認させて頂きました。
記事の内容としては
新規にexcelブックを作成するというものでした。
新規ではなく、既存のexcelシートに書き込む方法は無いでしょうか？
下記を参考にしてください。
■T'sWare Access Tips #432 ～Excelセルへ個別出力する基本パターン～
エラーがでるのはそこでしたか。先にそれを確認すべきでした。
stFilter = "・・・・"の部分はまったく関係ないですね。Str = Nz(Ctr.Value,"")
か原因というのは特定できましたが、なぜそうなるかはわからないですね。
コントロールの値が Null だとしても、Nz関数で "" に変換しているだけなので、エラーになるはずがないのてすが。
その前後１０行分のコードを張り付けてもらえますか。
お世話になります。
イミディエイトウィンドウにでるのは次です。
本部 In(2) And ([不備]=true Or [申請日]=#2019/04/10#)
デバッグは次です
オートフォントサイズプログラムの8行目です。
Str = Nz(Ctr.Value, "") 'ここでエラーが出る場合は、Str = Nz(Ctr.Value,"")
ちなみに当該レポートでオートフォントサイズを使わなければうまくいくようです。
オートフォントサイズプログラムここでも重宝しています。
こういう調べ方もあるんですね。勉強になります。
エラーが出たあと、イミディエイトウィンドウに出力されている条件式をコピーしてここに貼り付けてもらえますか。
あと、エラーだ出た時に、エラーダイアログの[デバッグ]ボタンをクリックしたときに反転表示されるコードはどこですか。
すみません。修正です。
stFilter = "本部 In(" & Mid(stFilter, 2) & ") And [申請日無し]='" & "不備" & "'or ( [申請日]=#" & [TXT申請] & "#)"
やはり抽出条件でデータ型が一致しませんと出ます。
クエリーで申請日無しを設け 申請日無し: IIf([不備]=-1,"不備")
stFilter = "本部 In(" & Mid(stFilter, 2) & ") And ([申請日無し] ="不備" Or [申請日]=#" & [TXT申請] & "#)"
としましたが受け付けてくれません。
お世話になります。
3でお示しされたものと一緒ですね。
抽出条件でデータ型が一致しませんと出ます。
何ででしょうかね。
宜敷お願いします。
それでは、下記ではどうですか。
お世話になります。
1では全申請日が表示されます。
2ではtxt申請日分だけ表示されます。
3では抽出条件でデータ型が一致しませんと出ます。
宜敷お願いします。
丁寧にご指導いただきありがとうございました。無事にできました。
作成できたということてすか。
解決ということでよろしいですか。
検診者一人が複数のカルテNoを持つことがないのなら、
「検査データ台帳」には、「健診者ID」 を持たせて、
テーブル「健診者台帳」 と テーブル「検査データ台帳」を「健診者ID」でリレーションシップを設定することになります。
そうすれば、集計クエリで３つのテーブルを結合して、
団体ID、採取日 でグループ化して、健診者ID を「カウント」に設定すれば希望の結果が出ると思います。
ありません。