Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


19378 / 76738 ←次へ | 前へ→

【62793】Re:ExcelからAccessへデータ受け渡し
発言  Yuki  - 09/9/2(水) 7:20 -

引用なし
パスワード
   ▼どらちゃん さん:

こんにちは。
サンプルをUPしますね。
7行目の17列からがタイトル行ですね。
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
0 hits

【62775】ExcelからAccessへデータ受け渡し どらちゃん 09/8/31(月) 19:58 質問
【62776】Re:ExcelからAccessへデータ受け渡し neptune 09/8/31(月) 23:02 発言
【62779】Re:ExcelからAccessへデータ受け渡し どらちゃん 09/9/1(火) 6:13 発言
【62780】Re:ExcelからAccessへデータ受け渡し どらちゃん 09/9/1(火) 12:34 質問
【62781】Re:ExcelからAccessへデータ受け渡し Yuki 09/9/1(火) 13:59 発言
【62783】Re:ExcelからAccessへデータ受け渡し どらちゃん 09/9/1(火) 15:30 質問
【62784】Re:ExcelからAccessへデータ受け渡し Yuki 09/9/1(火) 15:44 発言
【62793】Re:ExcelからAccessへデータ受け渡し Yuki 09/9/2(水) 7:20 発言
【62795】Re:ExcelからAccessへデータ受け渡し どらちゃん 09/9/2(水) 20:30 質問
【62799】Re:ExcelからAccessへデータ受け渡し Yuki 09/9/3(木) 8:52 発言
【62800】Re:ExcelからAccessへデータ受け渡し どらちゃん 09/9/3(木) 10:01 質問
【62801】Re:ExcelからAccessへデータ受け渡し Yuki 09/9/3(木) 12:23 発言
【62804】Re:ExcelからAccessへデータ受け渡し どらちゃん 09/9/3(木) 19:21 お礼
【62782】Re:ExcelからAccessへデータ受け渡し neptune 09/9/1(火) 14:42 発言
【62786】Re:ExcelからAccessへデータ受け渡し どらちゃん 09/9/1(火) 21:00 発言
【62789】Re:ExcelからAccessへデータ受け渡し neptune 09/9/1(火) 22:18 発言

19378 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free