テキスト取込からのデータ取込編集エラーについて

このQ&Aのポイント
  • ACCESS97でインポートしたテキストを文字を変換させて新しく修正したテキストを作成したい流れですがエラーになります。
  • ユーザー定期型は定義されていません。↓チェックとを入れるとMicrosoft DAO 3.6 Object Library↓下記のエラーになりますこの名前は既にあるモジュール、プロジェクト、オブジェクトライブラリで使われています。
  • テキストファイルを取込し、修正したデータを正常に出力するためのVBAコードの一部です。
回答を見る
  • ベストアンサー

テキスト取込からのデータ取込編集エラーについて

ACCESS97でインポートしたテキストを文字を変換させて新しく修正したテキストを 作成したい流れですがエラーになります。 ご教授お願いします。 ユーザー定期型は定義されていません。 ↓チェックとを入れると Microsoft DAO 3.6 Object Library ↓下記のエラーになります この名前は既にあるモジュール、プロジェクト、オブジェクトライブラリで使われています。 Private Sub cmd選択_Click() Dim objExcel As Object Dim varFilePath As Variant Dim bln As Boolean Dim infname As String Dim TName As String TName = "取込用" Call F_ExecuteSQL("DELETE FROM " & TName & "") Set objExcel = CreateObject("Excel.Application") varFilePath = objExcel.GetOpenFileName("Microsfot Access (*.txt), *.txt", , "txt選択") If varFilePath <> False Then infname = varFilePath DoCmd.TransferText acImportDelim, "取込定義", TName, infname, True Call Div MsgBox "修正したデータを正常出力しました。" End If Set objExcel = Nothing End Sub Private Sub Div() Dim infname As String Dim outfname As String Dim n_in As Integer Dim n_out As Integer Dim tmpREC As typREC Dim tmpSP As typSpace Dim tmpNL As typNewLine Dim tmpStr As String outfname = myReplaceB(infname, ".txt", ".r.txt") n_out = FreeFile() Open outfname For Output As #n_out n_in = FreeFile() Open infname For Binary As #n_in Get #n_in, , tmpNL Do Until EOF(n_in) Get #n_in, , tmpREC tmpStr = myReplaceB(tmpREC.REC400, Chr(0), "") Print #n_out, tmpStr 'datファイルが改行されてる場合は改行コードを読み捨て Get #n_in, , tmpSP Get #n_in, , tmpSP Get #n_in, , tmpSP Get #n_in, , tmpSP Loop Close #n_in Close #n_out End Sub Function myReplaceB(ByVal myString, ByVal myFind, ByVal myRp) 'Access2000風 replace関数 (Access97、Excel97用) '「大文字小文字半角全角カタカナひらがな」を区別する 2003/10/11 pPoy Dim strTmp As String Dim wk1 As Integer, wk2 As Integer Dim wk3 As Integer, wk4 As Integer '準備 If IsNull(myString) Then Exit Function If IsNull(myFind) Then Exit Function wk4 = Len(myFind) '検索する文字数 wk3 = Len(myString) '検索対象の文字数 '最初に見つかった位置 wk2 = InStr(1, myString, myFind, vbBinaryCompare) wk1 = 1 '検索開始位置 '無ければそのまま If wk2 = 0 Then myReplaceB = myString Exit Function End If '文字の最後まで置換 Do strTmp = strTmp & Mid(myString, wk1, wk2 - wk1) & myRp wk1 = wk2 + wk4 wk2 = InStr(wk1, myString, myFind, vbBinaryCompare) Loop Until wk2 = 0 strTmp = strTmp & Mid(myString, wk1, wk3) myReplaceB = strTmp End Function

質問者が選んだベストアンサー

  • ベストアンサー
  • piroin654
  • ベストアンサー率75% (692/917)
回答No.2

>Call F_ExecuteSQL("DELETE FROM " & TName & "") の F_ExecuteSQ が関数として設定されているならば、 という条件で、コンパイルして、エラーがでなければ 実行できるはずです。 関数が設定されていないならばNo1のような方法で 簡単に実行できるはずです。 (1)、(2)、(3)以外の他の部分については エラーが出るのか確認はしていませんが。

その他の回答 (1)

  • piroin654
  • ベストアンサー率75% (692/917)
回答No.1

(1) >この名前は既にあるモジュール、プロジェクト、 >オブジェクトライブラリで使われています。 Access 97 ではDAOのバージョンは3.5で、 すでに設定してあるものと思われますが。 参照設定で確認してみてください。 (2) >Call F_ExecuteSQL("DELETE FROM " & TName & "") F_ExecuteSQLという関数はどこにも見当たりませんが どこか標準モジュールにでも定義されているのですか。 (3) わざわざDAOを設定するならば、 "DELETE FROM " & TName & "" をSQL文とすると、もしこのSQL文を実行 したいのなら、変数宣言で Dim db As Database として、さらに Set db = DBEngine.Workspaces(0).Databases(0) として、 db.Execute("DELETE * FROM " & TName & "") と実行し、 最後に、 db.Close : Set db = Nothing とするのが普通だと思いますが。

david21
質問者

補足

(2)すいません。モジュールは伐採しております。 (3)ご指摘ありがとうございます。初心者なのでネットから集めたのを 色々混ぜて作ったのですが、やはり普通とは違いますよね・・・ ご指摘ありがとうございます。 ちなみに(1)ですが3.5を設定していればこのコードは出来ますでしょうか? すいません。変なご質問で

関連するQ&A

  • VBA(Excel2003)で文字列の切り出し

    下のプロシージャーで全角半角混じりの文字列を切り出し、別の文字列で結合しようと思いますがうまくいく場合といかない場合があります。 イミディエイト・ウィンドウ上とCell上で動作が違います。 Cell上でうまく表示させるにはどうしたらいいでしょうか? Sub Test() Dim myString(2) As String Dim i As Integer myString(0) = "airueo" myString(1) = "かきくけこ" myString(2) = "さシすせそ" For i = 0 To 2 Debug.Print MidMbcs(myString(i), 1, 5) & "...テスト" Cells(i + 1, 1).Value = MidMbcs(myString(i), 1, 5) & "...テスト" Next i End Sub Function LenMbcs(ByVal str As String) LenMbcs = LenB(StrConv(str, vbFromUnicode)) End Function Function MidMbcs(ByVal str As String, start, length) MidMbcs = StrConv(MidB(StrConv(str, vbFromUnicode), start, length), vbUnicode) End Function

  • データの取り込み

    VB6.0 SQLSERVER で開発しています。  EXCELにあるデータをSQLへ取り込みたいのですが 下記のようにすると取り込めるのですが EXCELに空白があるとエラーが出ます。 教えてください。  Dim strSQL As String Dim adoRsWork As ADODB.RecordSet Dim exl As Object Dim i As Integer Dim k As Long Dim mds As Boolean Dim rs As Variant Dim j As Integer Dim s As String Dim ct As Long Dim fno As Integer Dim fnm As String strSel1 = "SELECT" strSel1 = strSel1 & " A.品番" strSel1 = strSel1 & ",A.品名" strSel1 = strSel1 & ",A.倉番" strSel1 = strSel1 & ",A.数量" strFro1 = " FROM " strFro1 = strFro1 & " A_zaiko AS A" strSQL = strSel1 & " " & strFro1 Debug.Print (strSQL) Set adoRsWork = pbAdo.OpenRecordset(strSQL) Set exl = CreateObject("Excel.Sheet") mds = True fnm = "C:\Documents and Settings\デスクトップ\159.xls" j = adoRsWork.Fields.Count - 1 ReDim ctyp(j) As Boolean For i = 0 To j Select Case adoRsWork(i).Type Case 131, 139 ctyp(i) = True Case Else ctyp(i) = False End Select Next adoRsWork.Close Set exl = CreateObject("Excel.Application") exl.Application.Visible = True exl.Application.Workbooks.Open FileName:=fnm k = 1 If mds Then k = 2 End If gSvrADOActiveconnection.BeginTrans On Error Resume Next For k = k To 65536 s = "" If exl.Cells(k, 1) = "" Then Exit For For i = 0 To j If ctyp(i) Then s = s & "," & exl.Cells(k, i + 1) Else s = s & ",'" & exl.Cells(k, i + 1) & "'" End If Next s = Mid(s, 2) strSQL = "insert into " & strFro1 & " values (" & s & ")" pbAdo.OpenRecordset (strSQL) If Err <> 0 Then gSvrADOActiveconnection.RollbackTrans Close fno adoRsWork.Close MsgBox "更新エラー" & Chr(10) & Err & ": " & Error _ & Chr(10) & ct + 1 & " 件目に問題あり" _ & Chr(10) & strSQL End End If ct = ct + 1 Next gSvrADOActiveconnection.CommitTrans On Error GoTo 0 exl.Application.DisplayAlerts = False exl.Application.Quit adoRsWork.Close

  • データの取り込み

    VB6.0 SQLSERVER で開発しています。  EXCELにあるデータをSQLへ取り込みたいのですが 下記のようにすると159.xlsは開くのですがその後FORM付近で正しくない構文があります。とエラーになってしまいます。 何処がおかしいのでしょうか? 教えてください。  Dim strSQL As String Dim adoRsWork As ADODB.RecordSet Dim exl As Object Dim i As Integer Dim k As Long Dim mds As Boolean Dim rs As Variant Dim j As Integer Dim s As String Dim ct As Long Dim fno As Integer Dim fnm As String strSel1 = "SELECT" strSel1 = strSel1 & " A.品番" strSel1 = strSel1 & ",A.品名" strSel1 = strSel1 & ",A.倉番" strSel1 = strSel1 & ",A.数量" strFro1 = " FROM " strFro1 = strFro1 & " A_zaiko AS A" strSQL = strSel1 & " " & strFro1 Debug.Print (strSQL) Set adoRsWork = pbAdo.OpenRecordset(strSQL) Set exl = CreateObject("Excel.Sheet") mds = True fnm = "C:\Documents and Settings\デスクトップ\159.xls" j = adoRsWork.Fields.Count - 1 ReDim ctyp(j) As Boolean For i = 0 To j Select Case adoRsWork(i).Type Case 131, 139 ctyp(i) = True Case Else ctyp(i) = False End Select Next adoRsWork.Close Set exl = CreateObject("Excel.Application") exl.Application.Visible = True exl.Application.Workbooks.Open FileName:=fnm k = 1 If mds Then k = 2 End If gSvrADOActiveconnection.BeginTrans On Error Resume Next For k = k To 65536 s = "" If exl.Cells(k, 1) = "" Then Exit For For i = 0 To j If ctyp(i) Then s = s & "," & exl.Cells(k, i + 1) Else s = s & ",'" & exl.Cells(k, i + 1) & "'" End If Next s = Mid(s, 2) strSQL = "insert into " & strFro1 & " values (" & s & ")" pbAdo.OpenRecordset (strSQL) If Err <> 0 Then gSvrADOActiveconnection.RollbackTrans Close fno adoRsWork.Close MsgBox "更新エラー" & Chr(10) & Err & ": " & Error _ & Chr(10) & ct + 1 & " 件目に問題あり" _ & Chr(10) & strSQL End End If ct = ct + 1 Next gSvrADOActiveconnection.CommitTrans On Error GoTo 0 exl.Application.DisplayAlerts = False exl.Application.Quit adoRsWork.Close

  • リストボックス 複数選択の場合の値取得

    ACCESS2003を使用しています。 今、下記のプログラムにて リストボックスからファイル名を選び CSVをインポートさせ、更に選択したファイル名を新しいフィールドに書き込みをする。というシステムを作っています。 現在のプログラムですと、一つを選択した場合はうまく書き込めます。 ですが、複数同時選択する事はできますでしょうか? 長くて見づらいプログラムですが、参考までに掲載します。 よろしくお願いします。 Private Sub Form_Load() Dim oFSO As Object Dim oFile As Object Dim sTmp As String Const FolderPath = "\\St1\第2業務部\$運用\TESTkanno" sTmp = "" Set oFSO = CreateObject("Scripting.FileSystemObject") For Each oFile In oFSO.GetFolder(FolderPath).files If (Right(oFile.Name, 3) = "csv") Then sTmp = sTmp & ";" & Left(oFile.Name, InStr(oFile.Name, ".") - 1) End If Next If (Len(sTmp) > 0) Then sTmp = Mid(sTmp, 2) End If Me.lst_01.RowSource = sTmp 'Me.lst_01 = Null Set oFSO = Nothing End Sub Private Sub Cmd_01_Click() Dim ercd As Integer Dim LsName As String Dim TName As String Dim ITName As String Dim Name1 As String Dim Name2 As String Dim teigi As String Dim SQL As String Dim aa As Long Dim mySQL As String Dim db As Database Dim i As Integer Dim varData As Variant Dim strSelected As String strSelected = vbNullString With lst_01 For Each varData In .ItemsSelected strSelected = strSelected & .ItemData(varData - 1) & " " Next End With 'ファイル名の取得 strError = 0 LsName = "\\St1\第2業務部\$運用\TESTkanno\" TName = Left(strSelected, Len(strSelected) - 1) LsName = LsName & TName & ".csv" ITName = "T_Mas" 'レコードの追加 teigi = "RGB定義" DoCmd.TransferText acImportDelim, teigi, ITName, LsName, True SQL = "INSERT INTO T_Mas (ID1,ID,処理状況,請求日,学校識別コード,学校名,学校分類名,メールアドレス,名前,ふりがな,性別,生年月日,職業,高校所在地,高校名,学年,郵便番号,都道府県,区市町村&町域,番地以下,電話番号,FileName,区分,不備,不備理由,yu,gid,保留,処理済,件数報告日,納品日 )" & _ " SELECT [" & TName & "].[ID1], [" & TName & "].[ID],[" & TName & "].[処理状況], [" & TName & "].[請求日]," & _ " [" & TName & "].[学校識別コード], [" & TName & "].[学校名], [" & TName & "].[学校分類名], [" & TName & "].[メールアドレス]," & _ " [" & TName & "].[名前], [" & TName & "].[ふりがな], [" & TName & "].[性別], [" & TName & "].[生年月日]," & _ " [" & TName & "].[職業], [" & TName & "].[高校所在地], [" & TName & "].[高校名], [" & TName & "].[学年]," & _ " [" & TName & "].[郵便番号], [" & TName & "].[都道府県], [" & TName & "].[区市町村&町域], [" & TName & "].[番地以下]," & _ " [" & TName & "].[電話番号], [" & TName & "].[FileName], [" & TName & "].[区分], [" & TName & "].[不備], [" & TName & "].[不備理由], [" & TName & "].[yu], [" & TName & "].[gid]," & _ " [" & TName & "].[保留], [" & TName & "].[処理済], [" & TName & "].[件数報告日],[" & TName & "].[納品日], From" & "LsName" Name1 = TName & ".csv" Name2 = Left(TName, Len(TName) - 5) ret = MsgBox(Name1 & "を FileName、" & Name2 & "を 区分に追加しますか?", vbYesNo + vbQuestion, "インポート確認") Dim sql1 As String sql1 = "Update T_Mas SET FileName = '" & Name1 & "',区分 = '" & Name2 & "'" & " WHERE FileName Is Null AND 区分 Is Null" DoCmd.RunSQL sql1 End Sub

  • ブックに可変のファイル名テキストファイルからデータを取り込みたい

    こんにちは 昨日質問させていただいた、コードを修正して 開かれるファイル名が可変である場合にも対応させたいのですが、"*"をもちいてみてもうまく行きません。 どの様に指定するのかご存知の方教えてください。 "\Fuji.txt"これを\****.txt \*.txtとやってみましたがダメでした。 なお、041221_fuji.txtのように日付を6桁と"_"を入れてfujiとしたく、日付の6桁の数字のみ変えたいのです。 それを下記のコードに盛り込みたいのですが、何が足りないのかうまく行きません。 宜しくお願いします。 Sub ReadTxt() Dim myTxtFile As String Dim myBuf As String, wkdt() As String Dim i As Integer, j As Integer Application.ScreenUpdating = False myTxtFile = ActiveWorkbook.Path & "\Fuji.txt" Worksheets("郵便番号").Activate Open myTxtFile For Input As #1 Do Until EOF(1) Line Input #1, myBuf wkdt = Split(myBuf, vbTab) 'データをセルに展開する i = i + 1 For j = 0 To UBound(wkdt) Cells(i, j + 1) = wkdt(j) Next j Loop Close #1 End Sub

  • エクセルVBA:テキストデータ(txt)の読込(改行が変なところでされる)

    勉強しながら、エクセルVBAを組んでみたのですが うまくいきません。 テキストデータを以下のようなプログラムで読んだのですが (100行のデータを縦に並ぶように100個のセルの書き出す) 読み込みデータに「↓」で改行されているところでは 「↓」の間は同一行と見なされてしまうのですが どのようにしたら一行で一つのデータと見てくれるのでしょうか? 分かる方がいましたら教えて下さい。 よろしくお願いします。 Sub pon() '*** 変数の宣言 *** Dim filenum As String Dim i As Integer Dim num As Integer, ms As String, cnt As Integer Dim BookName As String, PathName As String Dim ca As String cnt = 1 i = 1 ca = Cells(1, 56) PathName = "C:\" textpath = Dir(PathName & "pon" & ca & ".txt") BookName = Dir(PathName & "pon" & ca & ".txt") Open PathName & BookName For Input As #1 'ファイルを開きます Do While Not EOF(1) Line Input #1, ms cnt = cnt + 1 Cells(1, 57) = BookName 'データの書き出し Cells(cnt, 56) = ms 'データの書き出し Loop Close #1 End Sub

  • VBAを使って名前をつけて保存をしたい(3)

    Sub 名前を付けて保存()   Dim wSeq  As String   Dim wStr  As String   Dim Flnm  As String   Dim wFlnm  As String   Dim sI   As Integer   Dim eI   As Integer   Dim wDir  As String   Dim ER   As Boolean   '   Sheets("データー").Select   Range("C3").Select   ActiveWorkbook.Save      wDir = "\\Jooo\センタ\AA\CC\"   Flnm = wDir & Format(Date, "【mmdd】") & ".xls"   wFlnm = Flnm   If Flnm = "False" Then     Exit Sub   End If   '   wSeq = 0   wSeq = Get_Seq(wDir, ER)   If ER Then     wStr = ""   Else     wStr = "(" & wSeq & ")"   End If   Flnm = Left(wFlnm, Len(wFlnm) - 4) & wStr & ".xls"   ActiveWorkbook.SaveAs Filename:=Flnm   Call Put_Seq(wDir, wSeq) End Sub '連番取得 Function Get_Seq(wDir As String, ER As Boolean) As Integer   Dim n As Long   Dim Seq As Integer   '   ER = False   Seq = 0   On Error GoTo ExitER   n = FreeFile   Open wDir & "連番.dat" For Input As #n   Input #n, Seq   Close #n   Get_Seq = Seq + 1   Exit Function ExitER:   ER = True   Seq = 1   On Error GoTo 0 End Function '連番保存 Function Put_Seq(wDir As String, wSeq As String)   Dim n As Long   n = FreeFile   Open wDir & "連番.dat" For Output As #n   Print #n, wSeq   Close #n End Function 先日回答者の方から上記を教えてもらったんですが、実行すると指定したフォルダに本日の日付+連番の名称でどんどん保存されるんですが (例:一回目実行→【1028】,二回目実行→【1028】(1),三回目実行→【1028】(2),四回目実行→【1029】(3),五回目実行→【1029】(4),※四回目以降は明日に実行した場合です),日付が変わった場合連番を最初からカウントするようにしたいのですが(例の【1029】(3)を【1029】に,【1029】(4)を【1029】(1)というふうに)どの様に上記を変更したらいいでしょうか?

  • アクセスのVBAでテキストデータのリンクを更新したいのですが

    コードは以下ですが、リンクの更新がうまくいかず更新されずに終了 してしまいます。 Function RefreshLinks(strFileName As String) As Boolean '指定されたデータベースへのリンクを更新します。更新に成功した場合は、True を返します。 Dim dbs As Database Dim intCount As Integer Dim tdf As TableDef 'データベースの全てのテーブルをループします。 Set dbs = CurrentDb For intCount = 0 To dbs.TableDefs.Count - 1 Set tdf = dbs.TableDefs(intCount) 'tdf.connectがある場合、それはリンクテーブルです。 If Len(tdf.Connect) > 0 Then tdf.Connect = "text;databese=" & strFileName Err = 0 On Error Resume Next tdf.RefreshLink 'テーブルのリンクを更新します。 If Err <> 0 Then RefreshLinks = False Exit Function End If End If Next intCount RefreshLinks = True 'リンクの更新が完了しました。 End Function

  • エクセルでのシート間のデータの移動について

    前回の質問ではこのような回答をしてもらいました。 ------------------------- Sub test() 'TXTファイル読み込みダイアログボックス Dim FileToOpen As String FileToOpen = Application.GetOpenFilename("テキストファイル (*.txt), *.txt") Dim myVal As String Dim x As Integer Dim y As Integer y = 1 '1列目から Open FileToOpen For Input As #1 ' シーケンシャル入力モードで開きます。 Do While Not EOF(1) ' ファイルの終端までループを繰り返します。 x = x + 1 Input #1, myVal Cells(x, y) = myVal If x Mod 20 = 0 Then'20行置きに y = y + 1 '列をずらす x = 1 '行をクリア End If Loop Close #1 ' ファイルを閉じます。 End Sub ------------------------- 今度はこのマクロを利用して同じファイル内のシートAAAにA1からA100までそれがC列まであるとします。 このデータをシートBBBに20行ずつ移したいのです。 わかる方がいましたら教えてください。 よろしくお願いします。

  • windows7でActivex.dllがエラー

    テストプログラムで下記のロジック project.dllの作成を実行した結果 Windows-XPでは正常に作成されるのに、 Windows7では  ”シシテム レジストリへのアクセスでエラーが発生しました。" エラーになります。 どこを直したらよろしいでしょうか? よろしくお願いいたします VB6.0でSP6を使用しております ・標準モジュール Sub Main() End Sub ・クラスモジュール Public MyString As String Public Function MyFunction() As String MyFunction = "You never know what you're gonna get." End Function  Public Sub Class_Initialize() MyString = "Life is like a box of chocolates."  End Sub