| |
▼どらちゃん さん：
こんにちは。
サンプルをUPしますね。
7行目の１７列からがタイトル行ですね。
MDBのパスとExcelのパスは変えてくださいね。
Sub TestInsert見本1()
Dim strMdb As String
Dim strTBL As String
Dim wb As Workbook
Dim strDir As String
Dim strSnm As String
Dim strFnm As String
Dim strSQL As String
Dim strSQL1 As String
Dim strSQL2 As String
Dim i As Long
Dim j As Long
Dim fldN() As String
Dim flg As Boolean
Dim sRow As Long
Dim eRow As Long
Dim sCol As Long
Dim eCol As Long
Dim strCol As String
Dim myDb As DAO.Database
Dim tblDf As DAO.TableDef
Dim fld As Object
Dim Dic As Scripting.Dictionary
strMdb = "D:\Access\Test.mdb" ' Access
strTBL = "T_INTESTa" ' Access
strDir = "D:\Excel\Test\" ' Excel
strSnm = strDir & "Sample.xls" ' Excel
strFnm = Dir(strSnm)
Set myDb = OpenDatabase(strMdb)
Set Dic = CreateObject("Scripting.Dictionary")
Set tblDf = myDb.TableDefs("T_INTESTa")
For Each fld In tblDf.Fields
' AccessのTableのフィールド名登録
Dic(Trim(fld.Name)) = Empty
Next
' ************************* フィールド名の為 ***************************
On Error Resume Next
Set wb = Workbooks(strFnm)
On Error GoTo 0
If wb Is Nothing Then
Set wb = Workbooks.Open(strSnm)
flg = True
End If
' フィールド名のセット
sRow = 7 ' 7行目はHeaderがあるとして ' Start行
sCol = 17 ' 17列目Start列
j = -1
With wb.Worksheets(1)
eCol = .Cells(17, .Columns.Count).End(xlToLeft).Column ' 最終列
strCol = Split(.Cells(1, eCol).Address, "$")(1) ' 列文字
eRow = .Range("Q" & .Rows.Count).End(xlUp).Row ' 最終行
For i = sCol To eCol
If Dic.Exists(Trim(.Cells(7, i))) Then
' Excel と Access のフィールド名が同じ物を登録
j = j + 1
ReDim Preserve fldN(j)
fldN(j) = Trim(.Cells(7, i))
End If
Next
End With
If flg Then wb.Close False
If j = -1 Then GoTo Proc_Close ' 合致するフィールド名が無かった時
For i = 0 To UBound(fldN)
' フィールド名の整形
strSQL1 = strSQL1 & fldN(i) & ", "
strSQL2 = strSQL2 & "T." & fldN(i) & ", "
Next
strSQL1 = Left(strSQL1, Len(strSQL1) - 2)
strSQL2 = Left(strSQL2, Len(strSQL2) - 2)
' ************************************************************************
' SQL文の結合
strSQL = "INSERT INTO [" & strTBL & "] " & _
"(" & strSQL1 & ") " & _
"SELECT " & strSQL2 & " " & _
"FROM [Sheet1$Q" & sRow & ":" & strCol & eRow & "] AS T " & _
"IN '" & strDir & strFnm & "' " & _
"'Excel 8.0;HDR=YES'"
' SQL文はDebug.Printで確認して下さい。
' 実行
myDb.Execute strSQL
Proc_Close:
myDb.Close
Set myDb = Nothing
End Sub
|
|
Yuki
- 09/9/2(水) 7:20 -
