| |
Option Compare Database
Private Sub aJ取り込み_Click()
On Error GoTo エラー
Dim strac As String
Dim strxls As String
Dim strrange As String
Dim strmsg As String
Dim mySQL As String
Dim strQry As String
strac = "T_Sample&POP"
strxls = "C:\Documents and Settings\CT207154\デスクトップ\取り込みデータ\●●●.xls" 'エクセルファイルを指定します。
strrange = "Q_FRM014_EXCEL依頼書出力ヘッダ!" 'データ入力のシート名とセル範囲を指定します。
strmsg = "aJデータを取り込みますか？" 'MsgBoxのメッセージです。
mySQL = "DELETE * FROM T_データ格納"
strQry = "Q_追加_取込aJデータ"
If MsgBox(strmsg, vbOKCancel, "MS") = vbOK Then
DoCmd.DeleteObject acTable, strac 'テーブルを削除します。
'最初のデータをフィールド名として使います。
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, _
strac, strxls, True, strrange
DoCmd.RunSQL mySQL 'T_データ格納テーブルを削除します。
DoCmd.OpenQuery strQry 'データ格納テーブルに取込データを追加します。
Me.Requery
Me.Refresh
MsgBox "データ入力は、正常に完了しました。"
End If
Exit Sub
エラー:
Select Case Err.Number
Case 7874
'エラーの原因となったステートメントの、
'次のステートメントからプログラムの実行を再開します。
Resume Next
Case Else
MsgBox "予期せぬエラーが発生しました。" & Chr(13) & Chr(13) & _
"エラー番号：" & Err.Number & Chr(13) & Chr(13) & _
"エラー内容：" & Err.Description, 1, "MS"
End
End Select
End Sub
Private Sub brand_Change()
Me.Requery
Me.Refresh
End Sub
Private Sub CHKALL_Click()
On Error GoTo Error1
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb
Set rs = Me.RecordsetClone
Me.Requery
Me.Refresh
If Me.CHKALL = True Then
rs.MoveFirst
Do Until rs.EOF
rs.Edit
rs!チェック = True
rs.Update
rs.MoveNext
Loop
Else
rs.MoveFirst
Do Until rs.EOF
rs.Edit
rs!チェック = False
rs.Update
rs.MoveNext
Loop
End If
Me.Refresh
rs.Close
Exit Sub
Error1:
MsgBox "もう一度試してみてください。", , "Hitachi Trasport System, Ltd."
End Sub
Private Sub Close_Click()
DoCmd.Quit acQuitSaveAll
End Sub
Private Sub Form_Click()
End Sub
Private Sub import_Click()
On Error GoTo エラー
Dim strac As String
Dim strxls As String
Dim strrange As String
Dim strmsg As String
Dim mySQL As String
Dim strQry As String
strac = "T_Sample&POP"
strxls = "C:\Documents and Settings\CT207154\デスクトップ\取り込みデータ\▲▲▲.xls" 'エクセルファイルを指定します。
strrange = "Q_FRM014_EXCEL依頼書出力ヘッダ!" 'データ入力のシート名とセル範囲を指定します。
strmsg = "ファイルをインポートします" 'MsgBoxのメッセージです。
mySQL = "DELETE * FROM T_データ格納"
strQry = "Q_追加_取込データ"
If MsgBox(strmsg, vbOKCancel, "MS") = vbOK Then
DoCmd.DeleteObject acTable, strac 'テーブルを削除します。
'最初のデータをフィールド名として使います。
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, _
strac, strxls, True, strrange
DoCmd.RunSQL mySQL 'T_データ格納テーブルを削除します。
DoCmd.OpenQuery strQry 'データ格納テーブルに取込データを追加します。
Me.Requery
Me.Refresh
MsgBox "データ入力は、正常に完了しました。"
End If
Exit Sub
エラー:
Select Case Err.Number
Case 7874
'エラーの原因となったステートメントの、
'次のステートメントからプログラムの実行を再開します。
Resume Next
Case Else
MsgBox "予期せぬエラーが発生しました。" & Chr(13) & Chr(13) & _
"エラー番号：" & Err.Number & Chr(13) & Chr(13) & _
"エラー内容：" & Err.Description, 1, "MS"
End
End Select
End Sub
Private Sub コマンド49_Click()
Me.Requery
Me.Refresh
End Sub
Private Sub 出力_Click()
On Error GoTo エラー
FileName = "C:\Documents and Settings\CT207154\デスクトップ\送り状ファイル\Sample変換データ" & Forms!F_menu![brand] & "" & Format(Now(), "yyyymmdd") & ".csv"
If MsgBox("抽出するデータにチェックをつけたことを確認してください。変換データを出力しますか？", vbYesNo) = vbYes Then
Me.Requery
Me.Refresh
DoCmd.TransferText acExportDelim, , "Q_出力明細2", FileName
MsgBox "指定のフォルダに保存完了しました。"
Exit Sub
Else
MsgBox "データの出力を中止いたしました！"
End If
Exit Sub
エラー:
Select Case Err.Number
Case 7874
'エラーの原因となったステートメントの、
'次のステートメントからプログラムの実行を再開します。
Resume Next
Case Else
MsgBox "予期せぬエラーが発生しました。" & Chr(13) & Chr(13) & _
"エラー番号：" & Err.Number & Chr(13) & Chr(13) & _
"エラー内容：" & Err.Description, 1, "Microsoft Access Club"
End
End Select
End Sub
＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿
ちょっと貼り付けてみました。
大まかにプログラムを説明すると、Excelを取り込むボタンが２種類あってそれぞれ別のExcelを取り込みます。(●●●.xlsと▲▲▲.xls)←中身のデータの並びは一緒です)
エラー内容は前述のとおりで、T_Sample&POP（またはSample&POP）が見つかりませんと表示されます。
変更してしまったファイル名は、一方だけなのですが、どちらのボタンをクリックしてもエラーが表示されてしまいます。
ちなみに、変更してしまった時のファイル名ですが★★★+元のファイル名という形で変更してしまっております。(★★★を取り除いても同様のエラーが出ます)
また、ファイル名を変更してしまい最初にエラーがでたときに、Accessのメニューの外部データの取り込みのインポートやリンクを実行してしまったためにプログラムに余計な行が追加されてしまっているかもしれません。
|
|
![[未読]](./data/access/image/read_icon.gif){kind=icon}
