FC2ブログ

スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

取り込みながらのテーブル分割と関連付け 


本題に入る前に・・・

チョッと気になる所があって・・・
前にも記述してましたが、ログからは、どこをクリックしたのか・・・が、わかります
記事の更新が1か月無いと広告表示になりますが、
その後からカウンターのクリックが発生してくるのは何故???
これを追ってみていたのですが、誰がクリックした・・・ログには無いようで・・・
・・・・実害はなさそうなので、今後は広告表示させない様に記事を書いていこうかと・・・

では本題です

Excel に以下の様なデータがあって、

kEnt200.jpg

効率良く(?)テーブル分割して、データを取り込むやり方について、チョッと模索してみる。
Excel シートの項目(1行目)には、
「圏」「地方1」「地方2」「都道府県番号」「都道府県名」の5項目があって、
「圏」「地方1」「地方2」の3つについては、それぞれ別のテーブルにしてみましょうか。

「圏」用のテーブル「T圏」では、
 「圏ID」(長整数:主キー)「圏名称」(テキスト)
 この「圏名称」が Excel から入手するもの

「地方1」用のテーブル「T地方1」では、
 「地方1ID」(長整数:主キー)「地方名称」(テキスト)
 この「地方名称」が Excel から入手するもの

「地方2」用のテーブル「T地方2」では、
 「地方2ID」(長整数:主キー)「地方名称」(テキスト)
 この「地方名称」が Excel から入手するもの

メインとするテーブルに「T都道府県」
 「都道府県ID」(長整数:主キー)
 「圏ID」「地方M」「地方S」(長整数)
 「都道府県名称」(テキスト)
 この「都道府県ID」、「都道府県名称」の2つが Excel から入手するもの
 「圏ID」「地方M」「地方S」は、「T圏」「T地方1」「T地方2」をルックアップする様に

各テーブルの関係は以下のようにしてみました。

kEnt200_1.jpg  kEnt200_2.jpg

テーブル「T地方1」「T地方2」に、
テーブル「T圏」を参照させるフィールドがあっても良いのかと思いますが・・・
(今回は「圏」「地方1」「地方2」の3つは単独で)
ただ、変更は簡単にできるように考えてみます。

上記取り込み用のテーブルは、事前に作っておく事が前提になりますけど・・・

サンプルファイルは、前記事「検索用途コンボの4階層連携 その2」にあります。
 
先に、標準モジュール「Module2」に記述したものは以下になります。
Public Sub DataMake2()
  Dim oApp As Object, r As Object
  Dim rs() As ADODB.Recordset
  Dim vT1 As Variant, vL1 As Variant
  Dim vT2 As Variant, vL2 As Variant
  Dim vT3 As Variant, vL3 As Variant
  Dim vT4 As Variant, vL4 As Variant
  Dim vA As Variant
  Dim v3 As Variant, v4 As Variant
  Dim vR As Variant, v As Variant
  Dim sSql As String
  Dim iRow As Long, iCol As Long
  Dim i As Long, j As Long

  Const CFILE As String = "\kEnt199.xls"
  Const xlWhole = 1


  vT1 = Array( _
      Array("圏ID", Empty), _
      Array("圏名称", "圏") _
    )
  vL1 = Empty
  vT2 = Array( _
      Array("地方1ID", Empty), _
      Array("地方名称", "地方1") _
    )
  vL2 = Empty
  vT3 = Array( _
      Array("地方2ID", Empty), _
      Array("地方名称", "地方2") _
    )
  vL3 = Empty
  vT4 = Array( _
      Array("都道府県ID", "都道府県番号"), _
      Array("都道府県名称", "都道府県名") _
    )
  vL4 = Array( _
      Array("圏ID", 0, "圏ID"), _
      Array("地方M", 1, "地方1ID"), _
      Array("地方S", 2, "地方2ID") _
    )

  vA = Array( _
      Array("T圏", 0, 1, vT1, vL1), _
      Array("T地方1", 0, 1, vT2, vL2), _
      Array("T地方2", 0, 1, vT3, vL3), _
      Array("T都道府県", 0, 0, vT4, vL4) _
    )

  Set oApp = CreateObject("Excel.Application")
  oApp.Visible = True
  With oApp
    .Workbooks.Open CurrentProject.Path & CFILE, ReadOnly:=True
    With .Worksheets("Sheet2")
      For i = 0 To UBound(vA)
        For j = 0 To UBound(vA(i)(3))
          Select Case True
            Case IsNull(vA(i)(3)(j)(1)), IsEmpty(vA(i)(3)(j)(1))
            Case Else
              Set r = .Rows(1).Find(vA(i)(3)(j)(1), LookAt:=xlWhole)
              If (r Is Nothing) Then GoTo INNER_ERROUT
              vA(i)(3)(j)(1) = r.Column
          End Select
        Next
      Next

      ReDim rs(UBound(vA))
      For i = 0 To UBound(vA)
        sSql = "DELETE * FROM " & vA(i)(0) & ";"
        CurrentProject.Connection.Execute sSql
        Set rs(i) = New ADODB.Recordset
        rs(i).Open vA(i)(0), CurrentProject.Connection, adOpenStatic, adLockOptimistic
      Next

      iRow = 2: iCol = 1
      While (.Cells(iRow, iCol).Value <> "")
        For i = 0 To UBound(vA)
          v3 = vA(i)(3)
          v4 = vA(i)(4)
          ReDim vR(UBound(v3))
          For j = 0 To UBound(v3)
            Select Case True
              Case IsNull(v3(j)(1)), IsEmpty(v3(j)(1))
              Case Else
                vR(j) = .Cells(iRow, v3(j)(1)).Value
            End Select
          Next
          rs(i).Filter = fncMakeFilter(v3, vR, vA(i)(2))
          If ((Len(rs(i).Filter) = 0) Or (rs(i).EOF)) Then
            rs(i).AddNew
            For j = 0 To UBound(v3)
              If (Not IsNull(v3(j)(1))) Then
                If (IsEmpty(v3(j)(1))) Then
                  vA(i)(1) = vA(i)(1) + 1
                  v = vA(i)(1)
                Else
                  v = vR(j)
                End If
                rs(i)(v3(j)(0)) = v
              End If
            Next
            If (Not IsEmpty(v4)) Then
              For j = 0 To UBound(v4)
                rs(i)(v4(j)(0)) = rs(v4(j)(1))(v4(j)(2))
              Next
            End If
            rs(i).Update
          End If
        Next
        iRow = iRow + 1
      Wend
      For i = 0 To UBound(vA)
        rs(i).Close
        Set rs(i) = Nothing
      Next
    End With
INNER_ERROUT:
    .Workbooks.Close
  End With
  oApp.Quit
  Set oApp = Nothing
End Sub


Private Function fncMakeFilter(v3 As Variant, vR As Variant, vNum As Variant) As String
  Dim sF As String, sS As String
  Dim i As Long
  Const CANDOR As String = " AND "
  Const CFLTS As String = CANDOR & "[{%1}] = '{%2}'"

  sF = ""
  For i = 0 To vNum
    Select Case True
      Case IsNull(v3(i)(1)), IsEmpty(v3(i)(1))
      Case Else
        sS = Replace(CFLTS, "{%1}", v3(i)(0))
        If (i = 0) Then
          sS = Replace(sS, "'{%2}'", vR(i))
        Else
          sS = Replace(sS, "{%2}", vR(i))
        End If
        sF = sF & sS
    End Select
  Next
  fncMakeFilter = Mid(sF, Len(CANDOR) + 1)
End Function

 
これだけではコメントも記述していないので、何が何だかわかりませんね・・・っということで
1行を取り込む時に、どのテーブルに展開していくか・・・以下で定義しておきます
  vA = Array( _
      Array("T圏", 0, 1, vT1, vL1), _
      Array("T地方1", 0, 1, vT2, vL2), _
      Array("T地方2", 0, 1, vT3, vL3), _
      Array("T都道府県", 0, 0, vT4, vL4) _
    )
テーブル「T圏」「T地方1」「T地方2」「T都道府県」に展開します。
      Array("T都道府県", 0, 0, vT4, vL4) _
部分は、
T都道府県:テーブル名
0:採番する際の初期値 - 1 ★1
0:重複を判別するフィールド数 - 1 ★2
vT4:登録するフィールド情報
vL4:他テーブルを参照する情報

そこで vT4 は?というと
  vT4 = Array( _
      Array("都道府県ID", "都道府県番号"), _
      Array("都道府県名称", "都道府県名") _
    )
で、左側がテーブル内のフィールド名、右側が Excel の見出し項目名
ここで、登録の際に都道府県番号だけを重複チェックしたいので、1 - 1 の 0 を(★2)
テーブル「T都道府県」では、他テーブルを参照するので
  vL4 = Array( _
      Array("圏ID", 0, "圏ID"), _
      Array("地方M", 1, "地方1ID"), _
      Array("地方S", 2, "地方2ID") _
    )
として
      Array("地方M", 1, "地方1ID"), _
フィールド「地方M」には、
定義 vA に記述した 1 番目のテーブルのフィールド「地方1ID」を設定してね・・・
(番目・・・は、0 スタート)

テーブル内のフィールドを定義する際、1つ目には、主キーにあたる数値型のものを・・・
これルールにしました・・・・(他テーブルとの結び付けには数値で)
テーブル「T都道府県」では、Excel 内の項目「都道府県番号」を使うので採番する必要はなかったのですが、
他のテーブル・・・例えば、テーブル「T圏」の定義では以下の様にします。
  vT1 = Array( _
      Array("圏ID", Empty), _
      Array("圏名称", "圏") _
    )
  vL1 = Empty
主キーにあたる部分
      Array("圏ID", Empty), _
の定義は、フィールド「圏ID」を採番してね・・・その初期値指定が★1
採番する際には、その初期値 + 1 から・・・・
自分で採番するのではなく、「圏ID」をオートナンバにしていたら
      Array("圏ID", Null), _
とすれば良いようにしていました。
このテーブル「T圏」では、他テーブルを参照する事は無いので vL1 = Empty
また、★2にあたる vA での定義は 1 になっていたので、2フィールドを・・・
「圏ID」は Empty 指定なので除外して、「圏名称」で重複をチェック・・・
重複チェックしたくない場合は、★2 部分に -1 指定すれば良いです。

定義部分はこんな感じです。
では、ここから処理の解説を・・・

  Set oApp = CreateObject("Excel.Application")
  oApp.Visible = True
  With oApp
    .Workbooks.Open CurrentProject.Path & CFILE, ReadOnly:=True
    With .Worksheets("Sheet2")

ここでは、Excel を起動し、読み込み対象のファイルを開いてます。
確認用の記述なので、すぐに Visible = True してますが、実際には表示する必要はないですね・・・

      For i = 0 To UBound(vA)
        For j = 0 To UBound(vA(i)(3))
          Select Case True
            Case IsNull(vA(i)(3)(j)(1)), IsEmpty(vA(i)(3)(j)(1))
            Case Else
              Set r = .Rows(1).Find(vA(i)(3)(j)(1), LookAt:=xlWhole)
              If (r Is Nothing) Then GoTo INNER_ERROUT
              vA(i)(3)(j)(1) = r.Column
          End Select
        Next
      Next

ここでは、定義した・・・例えば以下の定義右側が Excel 項目名として存在するか・・・
  vT4 = Array( _
      Array("都道府県ID", "都道府県番号"), _
      Array("都道府県名称", "都道府県名") _
    )
そして存在したら、その項目名部分を列( Column )数値で置き換えます。

以下では、全テーブルに対して Recordset を Open します。
      ReDim rs(UBound(vA))
      For i = 0 To UBound(vA)
        sSql = "DELETE * FROM " & vA(i)(0) & ";"
        CurrentProject.Connection.Execute sSql
        Set rs(i) = New ADODB.Recordset
        rs(i).Open vA(i)(0), CurrentProject.Connection, adOpenStatic, adLockOptimistic
      Next
この処理では、取り込み用テーブルを初期化(全レコード削除)していますが、
継続で取り込む・・・云々あれば、vA での定義内容に指示を追加するとかで対応できますね
今回は、無条件で初期化する様に・・・

      iRow = 2: iCol = 1
      While (.Cells(iRow, iCol).Value <> "")
        For i = 0 To UBound(vA)
          v3 = vA(i)(3)
          v4 = vA(i)(4)
          ReDim vR(UBound(v3))
          For j = 0 To UBound(v3)
            Select Case True
              Case IsNull(v3(j)(1)), IsEmpty(v3(j)(1))
              Case Else
                vR(j) = .Cells(iRow, v3(j)(1)).Value
            End Select
          Next
ここでは、Excel の1行を解釈する度に vA で定義したテーブル情報分繰り返します。
v3 は、テーブルのフィールド情報
v4 は、他テーブル参照情報
になっていて、また、v3 の Excel 項目名部分は、前の処理で列( Column )に書き変わっています。
読み込み領域 vR を確保して、必要なものを取り込んでいきます。
取り込んだもので、各 Recordset 内に重複があるか
          rs(i).Filter = fncMakeFilter(v3, vR, vA(i)(2))
          If ((Len(rs(i).Filter) = 0) Or (rs(i).EOF)) Then
確認していきますが、確認用の文字列は以下で作成します
Private Function fncMakeFilter(v3 As Variant, vR As Variant, vNum As Variant) As String
  Dim sF As String, sS As String
  Dim i As Long
  Const CANDOR As String = " AND "
  Const CFLTS As String = CANDOR & "[{%1}] = '{%2}'"

  sF = ""
  For i = 0 To vNum
    Select Case True
      Case IsNull(v3(i)(1)), IsEmpty(v3(i)(1))
      Case Else
        sS = Replace(CFLTS, "{%1}", v3(i)(0))
        If (i = 0) Then
          sS = Replace(sS, "'{%2}'", vR(i))
        Else
          sS = Replace(sS, "{%2}", vR(i))
        End If
        sF = sF & sS
    End Select
  Next
  fncMakeFilter = Mid(sF, Len(CANDOR) + 1)
End Function
※ ここでの処理は、vR(0) は数値用、以降の vR(1) ~ はテキスト用の決め打ちにしています。
実際には Recordset 内の各フィールドの型に合わせて文字列を作るように変更すべきですね・・・
また、何個のフィールド( vNum )で文字列作る・・・ vNum は v3 の配列内が前提の記述です
説明しておかないと・・・・ 後でバグ・・・・と言われても・・・・・

重複するものがなかったら登録します。
            rs(i).AddNew
            For j = 0 To UBound(v3)
              If (Not IsNull(v3(j)(1))) Then
                If (IsEmpty(v3(j)(1))) Then
                  vA(i)(1) = vA(i)(1) + 1
                  v = vA(i)(1)
                Else
                  v = vR(j)
                End If
                rs(i)(v3(j)(0)) = v
              End If
            Next
登録するフィールド情報の Excel 部分が
Null なら、オートナンバで採番する必要はない
Empty なら、自分で採番して・・・ 以外なら、読み込んだ値を設定して

これらをやる事によって、各 Recordset のカレントは結び付け参照できる状態で
            If (Not IsEmpty(v4)) Then
              For j = 0 To UBound(v4)
                rs(i)(v4(j)(0)) = rs(v4(j)(1))(v4(j)(2))
              Next
            End If
            rs(i).Update
他テーブルを参照する情報が定義してあったら、各 Recordset のカレントから値入手

・・・ってな流れに

※ vA で定義するテーブル順は、他のテーブルを参照するものは後に・・・


これを汎用的にするために、Array の定義部等をパラメータで渡すようにしてみたものが以下になります。
中の処理は、前述のものと変わりはありません。
標準モジュール「Module3」に記述したものは以下になります。
Public Sub DataMake3(ByVal sFile As String, ByVal sWsName As String _
      , ByVal vA As Variant, ByVal iRow As Long, ByVal iCol As Long)
  Dim oApp As Object, r As Object
  Dim rs() As ADODB.Recordset
  Dim v3 As Variant, v4 As Variant
  Dim vR As Variant, v As Variant
  Dim sSql As String, sS As String
  Dim i As Long, j As Long

  Const xlWhole = 1

  Set oApp = CreateObject("Excel.Application")
  oApp.Visible = True
  With oApp
    .Workbooks.Open CurrentProject.Path & "\" & sFile, ReadOnly:=True
    With .Worksheets(sWsName)
      For i = 0 To UBound(vA)
        For j = 0 To UBound(vA(i)(3))
          Select Case True
            Case IsNull(vA(i)(3)(j)(1)), IsEmpty(vA(i)(3)(j)(1))
            Case Else
              Set r = .Rows(iRow).Find(vA(i)(3)(j)(1), LookAt:=xlWhole)
              If (r Is Nothing) Then GoTo INNER_ERROUT
              vA(i)(3)(j)(1) = r.Column
          End Select
        Next
      Next

      ReDim rs(UBound(vA))
      For i = 0 To UBound(vA)
        sSql = "DELETE * FROM " & vA(i)(0) & ";"
        CurrentProject.Connection.Execute sSql
        Set rs(i) = New ADODB.Recordset
        rs(i).Open vA(i)(0), CurrentProject.Connection, adOpenStatic, adLockOptimistic
      Next

      iRow = iRow + 1
      While (.Cells(iRow, iCol).Value <> "")
        For i = 0 To UBound(vA)
          v3 = vA(i)(3)
          v4 = vA(i)(4)
          ReDim vR(UBound(v3))
          For j = 0 To UBound(v3)
            Select Case True
              Case IsNull(v3(j)(1)), IsEmpty(v3(j)(1))
              Case Else
                vR(j) = .Cells(iRow, v3(j)(1)).Value
            End Select
          Next
          sS = fncMakeFilter(v3, vR, vA(i)(2))
          If (Len(sS) > 0) Then
            rs(i).Filter = sS
            If ((Not rs(i).EOF) And (Not IsEmpty(v4))) Then
              Do While (Not rs(i).EOF)
                For j = 0 To UBound(v4)
                  If (rs(i)(v4(j)(0)) = rs(v4(j)(1))(v4(j)(2))) Then Exit Do
                Next
                rs(i).MoveNext
              Loop
            End If
          End If
          If ((Len(sS) = 0) Or (rs(i).EOF)) Then
            rs(i).AddNew
            For j = 0 To UBound(v3)
              If (Not IsNull(v3(j)(1))) Then
                If (IsEmpty(v3(j)(1))) Then
                  vA(i)(1) = vA(i)(1) + 1
                  v = vA(i)(1)
                Else
                  v = vR(j)
                End If
                rs(i)(v3(j)(0)) = v
              End If
            Next
            If (Not IsEmpty(v4)) Then
              For j = 0 To UBound(v4)
                rs(i)(v4(j)(0)) = rs(v4(j)(1))(v4(j)(2))
              Next
            End If
            rs(i).Update
          End If
        Next
        iRow = iRow + 1
      Wend
      For i = 0 To UBound(vA)
        rs(i).Close
        Set rs(i) = Nothing
      Next
    End With
INNER_ERROUT:
    .Workbooks.Close
  End With
  oApp.Quit
  Set oApp = Nothing
End Sub


Private Function fncMakeFilter(v3 As Variant, vR As Variant, vNum As Variant) As String
  Dim sF As String, sS As String
  Dim i As Long
  Const CANDOR As String = " AND "
  Const CFLTS As String = CANDOR & "[{%1}] = '{%2}'"

  sF = ""
  For i = 0 To vNum
    Select Case True
      Case IsNull(v3(i)(1)), IsEmpty(v3(i)(1))
      Case Else
        sS = Replace(CFLTS, "{%1}", v3(i)(0))
        If (i = 0) Then
          sS = Replace(sS, "'{%2}'", vR(i))
        Else
          sS = Replace(sS, "{%2}", vR(i))
        End If
        sF = sF & sS
    End Select
  Next
  fncMakeFilter = Mid(sF, Len(CANDOR) + 1)
End Function

 
で、この関数を使用した記述が以下になります。
Public Sub Samp1()
  Dim vT1 As Variant, vL1 As Variant
  Dim vT2 As Variant, vL2 As Variant
  Dim vT3 As Variant, vL3 As Variant
  Dim vT4 As Variant, vL4 As Variant
  Dim vA As Variant

  vT1 = Array( _
      Array("圏ID", Empty), _
      Array("圏名称", "圏") _
    )
  vL1 = Empty
  vT2 = Array( _
      Array("地方1ID", Empty), _
      Array("地方名称", "地方1") _
    )
  vL2 = Empty
  vT3 = Array( _
      Array("地方2ID", Empty), _
      Array("地方名称", "地方2") _
    )
  vL3 = Empty
  vT4 = Array( _
      Array("都道府県ID", "都道府県番号"), _
      Array("都道府県名称", "都道府県名") _
    )
  vL4 = Array( _
      Array("圏ID", 0, "圏ID"), _
      Array("地方M", 1, "地方1ID"), _
      Array("地方S", 2, "地方2ID") _
    )

  vA = Array( _
      Array("T圏", 0, 1, vT1, vL1), _
      Array("T地方1", 0, 1, vT2, vL2), _
      Array("T地方2", 0, 1, vT3, vL3), _
      Array("T都道府県", 0, 0, vT4, vL4) _
    )

  Call DataMake3("kEnt199.xls", "Sheet2", vA, 1, 1)
End Sub

 

また、これを使って、例えば前記事の内容を取り込む様に定義してみると以下の様になります
Public Sub Samp2()
  Dim vT1 As Variant, vL1 As Variant
  Dim vT2 As Variant, vL2 As Variant
  Dim vT3 As Variant, vL3 As Variant
  Dim vT4 As Variant, vL4 As Variant
  Dim vA As Variant

  vT1 = Array( _
      Array("id", Empty), _
      Array("cd", "勘定科目コード"), _
      Array("名称", "勘定科目") _
    )
  vL1 = Empty
  vT2 = Array( _
      Array("id", Empty), _
      Array("cd", "分類コード(機材番号)"), _
      Array("名称", "分類項目") _
    )
  vL2 = Array( _
      Array("id1", 0, "id") _
    )
  vT3 = Array( _
      Array("id", Empty), _
      Array("cd", "コード(機材番号)"), _
      Array("名称", "枝番(機材番号)") _
    )
  vL3 = Array( _
      Array("id2", 1, "id") _
    )
  vT4 = Array( _
      Array("an", Null), _
      Array("重量(kg)", "重量(kg)"), _
      Array("単位(損料)", "単位(損料)"), _
      Array("損料(円)(損料)", "損料(円)(損料)"), _
      Array("損料区分(損料)", "損料区分(損料)"), _
      Array("滅失価格(円)(損料)", "滅失価格(円)(損料)"), _
      Array("保有数H226運用計画表", "保有数H226運用計画表"), _
      Array("図面情報", "図面情報") _
    )
  vL4 = Array( _
      Array("id1", 0, "id"), _
      Array("id2", 1, "id"), _
      Array("id3", 2, "id") _
    )

  vA = Array( _
      Array("T1A", 0, 2, vT1, vL1), _
      Array("T1B", 0, 2, vT2, vL2), _
      Array("T1C", 0, 2, vT3, vL3), _
      Array("T1", 0, -1, vT4, vL4) _
    )

  Call DataMake3("kEnt199.xls", "Sheet1", vA, 1, 1)
End Sub

 
これで、「Module1」に記述した「DataMake」実行と同じ結果になります。
関連記事

2014/08/23

Category: サンプルかな

TB: --  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。