ACCESS VBA MSが教えてくれないテーブルに主キー(Primary Key)index Fieldを追加する方法

マイクロソフトの公式解説はバグが発生する

インデックスを作成および修正する
Microsoft Office 2000/Visual Basic プログラマーズ ガイド ADO を使用して Access データベースの構造を作成、変更、および表示するに次のような例が載っている

Sub CreateIndex(strDbPath As String, _
         strTblToIdx As String, _
         strIdxName As String, _
         strIdxField As String, _
         lngIndexNulls As ADOX.AllowNullsEnum, _
         lngSortOrder As ADOX.SortOrderEnum)
   Dim catDB As ADOX.Catalog
   Dim tbl As ADOX.Table
   Dim idx As ADOX.Index

   Set catDB = New ADOX.Catalog
   ' インデックスを作成するデータベースのカタログを開きます。
   catDB.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                            "Data Source=" & strDbPath
   Set tbl = New ADOX.Table
   Set tbl = catDB.Tables(strTblToIdx)

   ' Index オブジェクトを作成し、テーブル列に関連付けます。
   Set idx = New ADOX.Index
   With idx
      .Name = strIdxName
      .IndexNulls = lngIndexNulls
      .Columns.Append strIdxField
      .Columns(strIdxField).SortOrder = lngSortOrder
   End With

   ' Index オブジェクトを Table オブジェクトの Indexes コレクションに関連付けます。
   tbl.Indexes.Append idx

   Set catDB = Nothing
End Sub

'たとえば、CreateIndex プロシージャを使用して、Employee テーブルの Country フィールドを昇順に並べ替えて、Null を使用できるインデックスを作成するには、次のようなコードを使用します。

CreateIndex _
   "C:\Program Files\Microsoft Office\Office\Samples\Nwind.mdb", _
   "Employees", "CountryIndex", "Country", _
              "adIndexNullsIgnore","adSortAscending"

しかし、初心者にはわかりにくいが、このVBA、を

  Set catDB = New ADOX.Catalog
   ' インデックスを作成するデータベースのカタログを開きます。
   catDB.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                            "Data Source=" & strDbPath

Accdbの現在はプロバイダーが違う。
次に、このVBA「今開いているデータベースのテーブルにインデックスをつけようとしてもエラーになります。メッセージは「記憶領域が足りません」

カレントのデータベースのテーブルにインデックスをつける

作業の流れ

1. テーブルの名前をListとします。 2.追加するインデックスのフィールド名をID,データ形式はオートナンバーです。 3.これを追加して、次に2番目の列に移動します。 4.2番目の列に移動したら、1番目の列を2番目にすることにより入れ替えます。

   ###注意点

   • 事前にADOXとADODBを参照指定する。
   • テーブルには主キーが存在せず、「ID」という名前のフィールド（列）が存在しないこと
   • 出来上がる主キーは重複を許さない、空白を許さないものになること

   ADOXとADODB はいらないと言えばいらないのですが、比較するときに使ったり、ネットでは別の方法もありますので、先を見越して、追加しています。

   Sub AddIndexFieldOfPrimaryKeyColumn()
   Dim TName As String: TName = "ListMain"
   Dim fldName As String : fldName = "ID"
   Dim cDb As DAO.Database: Set cDb = CurrentDb
   Dim Cat As ADOX.Catalog: Set Cat = New ADOX.Catalog
   Dim cn As ADODB.Connection
   Dim CTbl As ADOX.Table
   Dim sSQL As String
   Dim fld0 As Field, fld1 As DAO.Field
   Dim i0 As Long, i1 As Long
   Dim idx As ADOX.Index, idxs As ADOX.Indexes, cCol As ADOX.Column, cCOLS As ADOX.Columns, cGrs As ADOX.Groups, CGr As ADOX.Group, cKeys As ADOX.Keys, cKey As ADOX.Key
   Call CloseAllAccessObject
   Cat.ActiveConnection = CurrentProject.Connection
   Set CTbl = Cat.Tables(TName)
   sSQL = "ALTER TABLE " & TName & " ADD COLUMN ID COUNTER PRIMARY KEY"
   DoCmd.RunSQL sSQL 'この状態ではID列は最も右側に位置している
   On Error Resume Next
   Set fld0 = cDb.TableDefs(TName).Fields(fldName)
   fld0.OrdinalPosition = 0 ’この命令で左から2番目に移動する
   Set fld1 = cDb.TableDefs(TName).Fields(0) ’一番左側のフィールド(列）を指定
   fld1.OrdinalPosition = 1　'2番目に持ってくることでID列が一番左(アクセスは0番から列をカウントするので物理的な列の位置-1となる)
   Set Cat = Nothing
   End Sub
   

   #STACK OVERFLOWのSQL(ALTER TABLE)を使う方法
   https://stackoverflow.com/questions/24238068/access-sql-alter-column-to-autonumber

    ALTER TABLE PERSON ALTER COLUMN PERSON_ID COUNTER PRIMARY KEY 
   

   というSQL(アクションクエリ)を使う方法があるが、これはデータがない空のテーブルでないと使えない。

   この意味はPERSONというテーブルのPERSON_IDという列(フィールド)を主キーに変更するという意味になる。
   #Adoxで一度成功した手法
   テーブルを開く必要がある

   Sub Sample
   Dim myCat As ADOX.Catalog: Set myCat = New ADOX.Catalog
   Dim idx As ADOX.Index, idxs As ADOX.Indexes, cCol As ADOX.Column, cCOLS As ADOX.Columns, cGrs As ADOX.Groups, CGr As ADOX.Group, cKeys As ADOX.Keys, cKey As ADOX.Key
   Dim tdNew As ADOX.Table
   myCat.ActiveConnection = CN
   fldName = "ID"
   Set tdNew = myCat.Tables(TName)
   tdNew.Columns.Append "ID", adInteger
   ' Index オブジェクトを作成し、テーブル列に関連付けます。
   Set IDX = New ADOX.Index
   With IDX
   .Name = "ID"
   .PrimaryKey = True
   .Columns.Append "ID"
   .Columns.Refresh
   End With
   tdNew.Columns.Refresh
   IDX.Columns.Refresh
   myCat.Tables.Refresh
   Application.RefreshDatabaseWindow: DoEvents
   DoCmd.OpenTable TName, acViewDesign 'デザインビューとして開く
   DoCmd.Save acTable, TName '保存　この動作をしないと定着しない
   DoCmd.Close
   End Sub
   

   #Daoを使う方法
   ADOXがエラーになるのは、データが入っていないテーブルを前提としており、データが入っているテーブル、フィールドにインデックスをつけられないということがわかった。

   Sub ImportTableAndAddPrimary
   'For Access VBA
   'CurrentProject.Path Import.xlsxをインポートして、No（ナンバーフィールド）を主キーにする
   Dim cDB As Dao.Database : Set cDB = CurrentDb
   Dim TDf As Dao.TableDef
   Dim idx As Dao.Index, idxs As Dao.Indexes
   Dim fld As Dao.Field, flds As Dao.Fields
   
   DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, TableName:=TName, FileName:=CurrentProject.Path & " import.xlsx", hasfieldnames:=True 'なぜか小文字になる
   DoEvents
   cDB.TableDefs.Refresh: DoEvents
   Application.RefreshDatabaseWindow: DoEvents
   Set TDf = cDB.TableDefs(TName)
   Set idx = TDf.CreateIndex("Get_ID")
   ' http://www.accessclub.jp/dao/21.html
   idx.Primary = True 'これをつけないと主キーにならない
   TDf.Indexes.Refresh
   Set flid = idx.CreateField("No")
   idx.Fields.Refresh
   idx.Fields.Append flid
   TDf.Indexes.Append idx
   TDf.Indexes.Refresh
   cDB.TableDefs.Refresh
   End Sub
   

   Daoその２ID列を追加して順番を変える方法(2022/07/24追加)

   MS Access Tips How To On Table Create "ID" Field With Primary And Set First Position
   上記のプロパティで移動させる手法が使えるようだ。
   Access VBA to Set Field Location
   一番最後に作って、0とすると最初に来る。
   このとき、なぜかfldsのような変数を使わず、CurrentDbから記述すると成功する。
   もちろんこうした例は検討していたが、ふとStackOverFlowをみてなんとなくCurrentDbから記述したら成功した。
   ただし、この移動量はいくつくらいか。列数が大きいときは定義が多すぎますエラーが出るかもしれない。単純に変更するだけなら1だが、移動するとなると、ほかを全部入れ替えていないか。そうするとはね上がる。

   Sub ADDPrimaryKeyFieldAndChangePosition()
   Dim cDB As DAO.Database:: Set cDB = CurrentDb
   Dim fld0 As DAO.Field, fld1 As DAO.Field
   Dim fldName As String
   Dim tName As String
   tName = "T_PartB"
   fldName = "ID"
   DoCmd.RunSQL "ALTER TABLE  [" & tName & "] ADD COLUMN [" & fldName & "] Counter PRIMARY KEY;"
   CurrentDb.TableDefs(tName).Fields(fldName).OrdinalPosition = 0 ' なぜかこのように指定したら成功
   CurrentDb.TableDefs(tName).Fields.Refresh
   CurrentDb.TableDefs.Refresh
   End Sub