[[20100922181041]]　『mdb⇔xls adoを使用して』（プリン）　ページの最後に飛ぶ

『mdb⇔xls adoを使用して』（プリン）xls2003 winxp

 xls以外の内容も含まれる質問なのでこちらでよいのか迷いました。
 過去に別件（xlsマクロで）こちらでご教示いただき再度こちらならと書き込みいたしました。
 adoの使用は完璧なシロウトです。
 web検索やこちらの全文でもhitしなかったのでお分かりの方がおりましたらご教示ください。

 mdbに保存してあるデータをエクセルのようにフィルタをかけたように複数条件（日付・id・氏名など）で検索しhitしたら1行（重複は無いです）をxlsのシートに貼り付け

 その後読み出したxlsの1行内容を修正や変更した後にmdb側の内容を変更・更新したい

 また、hitが無い場合は新規としてxls側のデータをmdbへ新規登録させたい

 上記内容が出来ません。

 検索して読込は出来ましたがhitしない場合はエラーとなる。
 書き込みは新規の書き込みは出来るが更新は出来ない。

 というのが現状でしょうか...

 mdbファイル　aaa.mdb
 テーブル syuukei
 フィールド 9個

 xls
 sheet1
 g2:p16までを使用しています

 別で

 mdbファイル　aaa.mdb
 テーブル staff
 フィールド　5個

 同一xlsのa15:e15以下を使用し別データの読込を行わせ、無ければ最下行に追加したものをmdbに保存は出来たので同じでいいかなってやったら無理でした。

 違いといえば空白セルが保存出来ないほうには存在するくらいかな

 助けてください。
 今回久々に作成しているbookはこのコードが出来れば完成なのですが座礁しました。

 こんばんは
 コードはどこまで出来ているのですか？
 空白セルの件は mdbファイルのフィールドが Null値が許可されていないのでしょうから、
 スペースかゼロをセットすればいいのでは？
（ウッシ）

 検索して取得するコードはサンプルをwebでいただき、下記のようにしてみました。
 日付と氏名で検索し、うまくデータがヒットすると取得できますが（データによって？デバイスioエラーというのが出る）、無い場合は取得できません。（完了できない　下記参照）
 求めることは、無い場合は何もしない...のです。
 この後の処理であった場合は内容を更新してmdbに行の上書き保存（言葉が違うかな？）を行う。
 無かった場合は情報を入力して新規にmdbに保存したい。というところです。

 Sub Get_syuukei()
    Dim key_x, key_y As Variant
    key_x = Worksheets("flag").Cells(7, 2)
    key_y = Worksheets("flag").Cells(5, 2)
    Dim cnn As New ADODB.Connection
    Dim rec As New ADODB.Recordset
    Dim strSQL As String
    Dim dbNAME, dbPath, myDB, tbl As String
    dbNAME = "syuukei.mdb"
    dbPath = ThisWorkbook.path
    tbl = "syuukei"
    fldnm = "date"
    fldnm2 = "name"
    strRTR = key_x
    strRTR2 = key_y
    myDB = dbPath & "\" & dbNAME
    myHomeSheetsName = "flag"

    Dim cat As New ADOX.Catalog
    Dim col As ADOX.Column
    cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & myDB & ";"

    Set cat = New ADOX.Catalog
    cat.ActiveConnection = cnn
    Worksheets(myHomeSheetsName).Select
    cnt = 7
    For Each col In cat.Tables(tbl).Columns
       Cells(1, cnt) = col.Name: cnt = cnt + 1
    Next
    strSQL = "SELECT * FROM " & tbl & " where " & fldnm & " like '" & strRTR & "%' AND " & fldnm2 & " like '" & strRTR2 & "%'"
    rec.Open strSQL, cnn, adOpenDynamic, adLockReadOnly
    i = 2
    rec.MoveFirst

    Do While Not rec.EOF
       For j = 1 To rec.Fields.Count
          Worksheets(myHomeSheetsName).Cells(i, j + 6) = rec.Fields(j - 1).Value
       Next j
       i = i + 1
       rec.MoveNext
    Loop

    Set cat = Nothing
    rec.Close: Set rec = Nothing
    cnn.Close: Set cnn = Nothing
    Exit Sub
 ErrorHandler:
    MsgBox (Err.Number)
    Resume Next
    Err.Clear
 End Sub

 rec.MoveNext←のところでエラー3021になります（検索条件が無い...場合です）

 null値...　空文字列ですか。たくさんありますね。
 入力して保存するときに数値の場合0か文字列はスペースを代入すると保存できるのかなぁ？　保存の方は今やってみます。

 こんにちは
 データが無い場合はこんな感じで、
 Sub Get_syuukei()
    Dim key_x, key_y
    Dim cnn As New ADODB.Connection
    Dim rec As New ADODB.Recordset
    Dim strSQL As String
    Dim myDB   As String
    Dim dbPath As String
    Dim sh     As Worksheet
    Dim cnt    As Long

    Const myHomeSheetsName = "flag"
    Const dbNAME = "syuukei.mdb"
    Const tbl = "syuukei"
    Const fldnm = "date"
    Const fldnm2 = "name"

    dbPath = ThisWorkbook.Path

    Set sh = Worksheets(myHomeSheetsName)
    key_x = sh.Cells(7, 2)
    key_y = sh.Cells(5, 2)

    myDB = dbPath & "\" & dbNAME
    cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & myDB & ";"

    strSQL = ""
    strSQL = strSQL & "SELECT * FROM " & tbl
    strSQL = strSQL & " WHERE " & fldnm & "  LIKE '" & key_x & "%' "
    strSQL = strSQL & "AND "
    strSQL = strSQL & fldnm2 & " LIKE '" & key_y & "%'"

    rec.Open strSQL, cnn, adOpenDynamic, adLockReadOnly

    For cnt = 0 To rec.Fields.Count - 1
        sh.Cells(1, cnt + 7).Value = rec.Fields(cnt).Name
    Next cnt

    If rec.BOF Or rec.EOF Then
        MsgBox "対象データ有りません"
    Else
        sh.Cells(2, 7).CopyFromRecordset rec
    End If

    rec.Close: Set rec = Nothing
    cnn.Close: Set cnn = Nothing
    Exit Sub
ErrorHandler:
    MsgBox (Err.Number)
    Resume Next
    Err.Clear
End Sub
（ウッシ）

 ウッシ様
 早々のご教示本当にありがとうございます。
 読込の方はスムースに処理が進行し全く問題ありませんでした。

 If rec.BOF Or rec.EOF Then
         MsgBox "対象データ有りません"
     Else
         sh.Cells(2, 7).CopyFromRecordset rec
 End If

 この部分は上にも下にもデータが見当たらない（該当のセルが見当たらない）という認識で良いのでしょうか。

 またstrSQLの箇所はこのような分割したきれいな文章があるんですね。
 とても見やすく助かりました。（この部分で2日ほど条件を追加するのに悩みました）
 これであればANDを使用し更に絞ることも可能ですね。

 下記に保存する際のコードを記載します

 Sub INS_time()
    On Error GoTo ErrorHandler
    Dim cnn As New ADODB.Connection
    Dim rec As New ADODB.Recordset
    Dim strSQL As String
    Dim dbNAME, dbPath, myDB, tbl As String

    dbNAME = "syuukei.mdb"
    dbPath = ThisWorkbook.path
    tbl = "syuukei"
    myDB = dbPath & "\" & dbNAME
    myHomeSheetsName = "flag"

    cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & myDB & ";"
    Worksheets(myHomeSheetsName).Select
    RowCNT = Range("g" & Rows.Count).End(xlUp).Row
    ClmCNT = 16
    For i = 2 To RowCNT
       strDATA = ""
       For j = 7 To ClmCNT
          If j = ClmCNT Then
             strDATA = strDATA & "'" & Cells(i, j).Value & "'"
          Else
             strDATA = strDATA & "'" & Cells(i, j).Value & "',"
          End If
       Next j
       strSQL = "insert into " & tbl
       strSQL = strSQL & " values (" & strDATA & ");"
       cnn.Execute strSQL
    Next i

    cnn.Close: Set cnn = Nothing
    Exit Sub
 ErrorHandler:
    Resume Next
    Err.Clear
 End Sub

 こちらのコードでは、保存データの範囲の問題でなく
 参照先のエクセルのセル範囲を変えて別のテーブルに保存する場合は問題なく機能します。
 というのは、こちらは基本情報（IDをKEYにして氏名やその他情報など全てを入力する）
 読込は全てを読み込み、無ければ最下行に新規で入力し実行するとテーブルにも新規は保存される（変更は今のところ無かったからかな？）

 今度のテーブルは主KEYが無かったのでナンバーのfldnmを作成しオートナンバーを追加して主KEYにしたこと、入力する情報は日付やテキスト、時刻や数値などが存在し内容によっては後から追加・変更もありそれまで日付や氏名などを除き空白で保存することもあります。

 今現在はやはり流用しても走らない状態です。

 CN.Execute　や　rs.Fields　で組んでみても思うように行きません。　CN ⇔CNN　などの違いはもちろん修正していますが勉強不足（わからない人間は手を出すな...的な世界です）エクセルマクロとは似て非なるものですね。（なめたことを申してすみません）
（プリン）

 こんにちは
 If rec.BOF Or rec.EOF Then で、読み込んだレコードセットにデータが無い事を確認してます。

 コード提示する場合は、この前のコメントで修正したコードを参考にしてインデントを付けて下さい。読みづらくて仕方ないです。

 貼り付ける時に、「Sub INS_time() 」のようなコードの先頭部分の前に半角スペースを入れると改行が反映されるそうです。
（ウッシ）

 すみませんでした。先ほど気づきました。半角スペースでしたね。

 Sub INS_syuukei()
    On Error GoTo ErrorHandler
    Dim cnn As New ADODB.Connection
    Dim rec As New ADODB.Recordset
    Dim strSQL As String
    Dim dbNAME, dbPath, myDB, tbl As String

    dbNAME = "syuukei.mdb"
    dbPath = ThisWorkbook.path
    tbl = "syuukei"
    myDB = dbPath & "\" & dbNAME
    myHomeSheetsName = "flag"

    cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & myDB & ";"
    rs.Open tbl, cnn, ADODB.CursorTypeEnum.adOpenDynamic, ADODB.LockTypeEnum.adLockOptimistic

    Worksheets(myHomeSheetsName).Select

    RS.Update()

    rs.Close: Set rs = Nothing
    cnn.Close: Set cnn = Nothing

    Exit Sub
ErrorHandler:
    MsgBox (Err.Number)
    Resume Next
    Err.Clear
End Sub

 現在このような形で簡潔にし、RS.Update()　の箇所をどうするか...　で止まっています。（ぷりん）

 ご指摘の件整形して再度修正いたしました。（プリン）

 こんにちは
 今回の質問の内容は？
 flagシート上の複数件のデータを修正してテーブルに書き戻して、新規レコードは追加するのですか？
 シート上のデータから 1件ずつ処理するとしたら、こんな感じになると思うのですが、
 Sub INS_syuukei()
    Dim key_x, key_y
    Dim cn     As ADODB.Connection
    Dim rs     As ADODB.Recordset
    Dim i      As Long
    Dim strSQL As String
    Dim ConnectionString As String

    Const dbNAME = "syuukei.mdb"
    Const tbl = "syuukei"
    Const fldnm = "ID"

    ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
    Set cn = New ADODB.Connection
    cn.Open ConnectionString & ThisWorkbook.Path & "\" & dbNAME  
    Set rs = New ADODB.Recordset

    For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
        key_x = Cells(i, 1) 'ID

        strSQL = ""
        strSQL = strSQL & "SELECT * FROM " & tbl
        strSQL = strSQL & " WHERE " & fldnm & "=" & key_x

        rs.Open strSQL, cn, adOpenKeyset, adLockOptimistic

        If rs.BOF Or rs.EOF Then
            rs.AddNew
            rs!名前 = Cells(i, 2)
            rs!生年月日 = Cells(i, 3)
            rs!性別 = Cells(i, 4)
            rs.Update
       Else
            rs!名前 = Cells(i, 2)
            rs!生年月日 = Cells(i, 3)
            rs!性別 = Cells(i, 4)
            rs.Update
        End If
        rs.Close
    Next    
    Set rs = Nothing
    cn.Close: Set cn = Nothing
End Sub
（ウッシ）

 ウッシ様
 早々のご教示ありがとうございます。
 書き込む際にidだけでなく登録日というフィールドデータも検索という感じです。

 For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    key_x = sh.Cells(7, 2)   ’id
    key_y = sh.Cells(5, 2)   ' 登録日

    strSQL = ""
    strSQL = strSQL & "SELECT * FROM " & tbl
    strSQL = strSQL & " WHERE " & fldnm & "  LIKE '" & key_x & "%' "
    strSQL = strSQL & "AND "
    strSQL = strSQL & fldnm2 & " LIKE '" & key_y & "%'"

 読み込んだデータを同一条件のデータに上書きする場合は上記で応用して検証してみます。
 rs!名前 の名前の部分はフィールド名ですね。　この場合はいろんなフィールド名の指定の仕方があるのですね。これで完成は出来そうですがもっと習得してみたくなりました。

 検証後不明な点がありましたらまたご教示していただきたいと思っておりますのでその際はご指導を宜しくお願いいたします。（プリン）

 やはりオートナンバーのフィールドを更新する際にエラーになってしまいます
 もう少しいじってみます（プリン）

 こんばんは
 オートナンバーのフィールドはオートナンバーなので更新出来ないです。
 それ以外のフィールドだけ更新します。
 レコードの追加の場合はオートナンバーのフィールドは自動採番されます。
（ウッシ）

 ウッシ様
 オートナンバーの件、削除したら問題なく走ることが出来ました。

 ウッシ様に作成していただいたものはどこのwebよりも綺麗でわかりやすいもので本当に感謝いたします。
 マクロと似て非なるものが同じようなものに見えてきましたし、明らかに今後の私のチャレンジの範囲が広がったことに感謝しています。
 まだシロウトでわかったっぷりのところが有りますので精一杯調べて理解をしていきたいと思います。
 以前からエクセルでのデータベースは限度がありアクセスを利用できたらと考えていました。

 アクセス以外にsqlの世界は広いので、自宅のブログのようにmySQLや色んなことにチャレンジして楽しんでいきたいと思います。
 ありがとうございました。（プリン）

コメント返信：

[ 一覧(最新更新順) ]

[[20100922181041]] 『mdb⇔xls adoを使用して』（プリン） ページの最後に飛ぶ

[[20100922181041]]　『mdb⇔xls adoを使用して』（プリン）　ページの最後に飛ぶ