人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

お気持ちのみですが合計で250ポイント?差し上げます。

以下の作業を自動化する EXCEL VBAマクロを作って下さい。

***作業***
Microsoft Access経由でリンクしている15個程度のテーブルへ、エクセルファイルからデータをコピー&ペーストしています。

作業は単純作業で、エクセルファイルの2行目から下(1行目はテーブルのフィールド名と一致する文字列が記載)をアクセス経由で開いたデータベースへコピー&ペーストしています。
***



***要件***
コメント欄に記載
***

●質問者: ReoReo7
●カテゴリ:コンピュータ ウェブ制作
✍キーワード:access Excel Microsoft VBA アクセス
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● Mook
●500ポイント ベストアンサー

一応下記のやり取りで想定した動作をするマクロです。

下記を想定しています。


マクロ実行ファイルのSheet1

A列・・・ID(処理の範囲:空のセルで終了)
B列・・・EXCEL ファイルのフルパス(例:D:\Data\sample.xls)
C列・・・格納先のテーブル名(例:sampleTable1)
D列・・・書き込み結果、エラー情報の出力

読み込みファイル(sample.xls) の例(上記のB列で指定)

1行目・・・・・カラム名(例:userName, price, address 等)
2行目以降・・・データ(例:山田, 25000, 東京都千代田区千代田1番)

マクロを実行するためには下記の準備が必要です。

(1)ODBC 5.1をダウンロードしてインストールしてください。

(コントロールパネルのプログラムの追加と削除で、すでに存在していればそのままでOKです。)

(2)VBEで「ツール」⇒「参照設定」から「Microsoft ActiveX Data Object(最新版を選択) Library」にチェック


マクロは下記のとおりです。先頭の ConnectionString の中身を正しい接続情報にしてください。

Option Explicit

Const ConnectionString = "Driver={MySQL ODBC 5.1 DRIVER};" _
 & " SERVER=localhost;" _
 & " DATABASE=sample_db;" _
 & " USER=sample_user;" _
 & " PASSWORD=sample2;"

'----------------------------------------------------
Sub dataExport()
'----------------------------------------------------
 Dim srcWS As Worksheet
 Set srcWS = ThisWorkbook.Worksheets("Sheet1")

 Dim lastRow As Long
 lastRow = srcWS.Range("A1").End(xlDown).Row
 
 Dim con As New ADODB.Connection
 con.Open ConnectionString
 
 Dim ll As Long
 For ll = 2 To lastRow
 srcWS.Cells(ll, "D").Value = XL2DB(con, srcWS.Cells(ll, "B").Value, srcWS.Cells(ll, "C").Value)
 Next

End Sub

'----------------------------------------------------
Function XL2DB(con As ADODB.Connection, srcPath As String, tableName As String) As String
'----------------------------------------------------
 If Dir(srcPath) = "" Then
 XL2DB = "EXCEL ファイルがありません"
 Exit Function
 End If
 
 Dim wb As Workbook
 Set wb = Workbooks.Open(srcPath)
 
 Dim ws As Worksheet
 Set ws = wb.Worksheets(1)
 
 Dim rs As ADODB.Recordset
 
 Dim i As Long
 Dim sql As String
 For i = 2 To ws.Range("A1").End(xlDown).Row
 sql = makeSQL(ws, tableName, i)
 On Error GoTo DB_ERR
 con.Execute sql
 On Error GoTo 0
 Next
 wb.Close

 GoTo NORMAL_END
DB_ERR:
 If XL2DB = "" Then
 XL2DB = "Line " & i & ":" & Err.Description
 Else
 XL2DB = XL2DB & vbNewLine & "Line " & i & ":" & Err.Description
 End If
 Resume Next
NORMAL_END:
End Function

'----------------------------------------------------
Function makeSQL(ws As Worksheet, tableName As String, dLine As Long) As String
 makeSQL = "INSERT INTO " & tableName & " (" & ws.Cells(1, 1).Value
 
 Dim sl As Long
 For sl = 2 To ws.Range("A1").End(xlToRight).Column
 makeSQL = makeSQL & "," & ws.Cells(1, sl).Value
 Next
 
 If IsNumeric(ws.Cells(dLine, 1)) Then
 makeSQL = makeSQL & " ) VALUES ( " & ws.Cells(dLine, 1).Value
 Else
 makeSQL = makeSQL & " ) VALUES ( '" & ws.Cells(dLine, 1).Value & "'"
 End If
 
 For sl = 2 To ws.Range("A1").End(xlToRight).Column
 If IsNumeric(ws.Cells(dLine, sl)) Then
 makeSQL = makeSQL & ", " & ws.Cells(dLine, sl).Value
 Else
 makeSQL = makeSQL & ", '" & ws.Cells(dLine, sl).Value & "'"
 End If
 Next
 
 makeSQL = makeSQL & " );"
End Function

データは数値と文字列に応じて形式を整えていますが、文字列型に数字のデータを入れる場合、

うまく動かない可能性があります。

その際は、カラムにデータ型を指定する必要がありますので、その際はコメントください。


一応動作確認済みです。

◎質問者からの返答

いつも大変助かっています。

ありがとうございます。試してみたいと思います。

*追記

仕様を変更して申し訳ないのですが、複数の使用者・複数のPCでの使用が考えられ、インストールなどの作業はなるべく無しで使用できるようにしたいと考えています。そこで、ODBC5.1などのインストールの作業はなるべく省略したいと考えています。

別に、Access(.mdbファイルは使用者全員が持つ)経由で開く方法を、本プログラムとは別の2つ目のお答えとしてご提示願えませんでしょうか?

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ