'標準モジュールを作成して保存
'緊急修正は、private sub mainのところにカーソルを当て、↑の実行（三角）ボタンを押す
'ACCESSの修正が完了したら、private sub modosuのところにカーソルをあて、実行ボタンを押す

Private Sub CreateTable()
Dim dbs As Database
Dim qdf As QueryDef

On Error GoTo err_trap


Set dbs = CurrentDb
Set qdf = dbs.CreateQueryDef("")
qdf.sql = "CREATE TABLE t_changetable (OldName varchar(255),NewName varchar(255));"


  qdf.Execute

exit_here:
  Set qdf = Nothing
  Set dbs = Nothing
  Application.RefreshDatabaseWindow
  Exit Sub
err_trap:
 MsgBox "CreateTableエラー" & err.Number & " " & err.Description
 Resume exit_here

End Sub

Private Sub AppendTable(ByVal oldname As String, ByVal NewName As String)
Dim dbs As Database
Dim qdf As QueryDef

On Error GoTo err_trap


Set dbs = CurrentDb
Set qdf = dbs.CreateQueryDef("")
qdf.sql = "INSERT INTO t_changetable (OldName,NewName) values('" & oldname & "','" & NewName & "')"

DoCmd.SetWarnings False
  qdf.Execute
DoCmd.SetWarnings True

exit_here:
  Set qdf = Nothing
  Set dbs = Nothing
  Exit Sub
err_trap:
 MsgBox "AppendTableエラー:" & err.Number & " " & err.Description
 Resume exit_here

End Sub

Private Sub AlterTableAndMakeQ()
Dim dbs As Database
Dim Tbl As TableDef
Dim rst As Recordset
Dim qdf As QueryDef
Dim sql As String

On Error GoTo err_trap

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("t_changetable")
rst.MoveFirst

Do Until rst.EOF
  Set Tbl = dbs.TableDefs(rst!oldname)
  Tbl.Name = rst!NewName
  sql = "SELECT * FROM " & rst!NewName
  Set qdf = dbs.CreateQueryDef(rst!oldname, sql)
  
  rst.MoveNext
Loop


exit_here:
  Set qdf = Nothing
  Set Tbl = Nothing
  Set dbs = Nothing
  Exit Sub
err_trap:
 MsgBox "AlterTableAndMakeQエラー:" & err.Number & " " & err.Description
 Resume exit_here

End Sub

Private Sub modosu()
Dim dbs As Database
Dim Tbl As TableDef
Dim rst As Recordset
Dim qdf As QueryDef
Dim sql As String

On Error GoTo err_trap

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("t_changetable")
rst.MoveFirst

Do Until rst.EOF
  dbs.QueryDefs.Delete rst!oldname

  Set Tbl = dbs.TableDefs(rst!NewName)
  Tbl.Name = rst!oldname
  
  rst.MoveNext
Loop


Application.RefreshDatabaseWindow
exit_here:
  Set qdf = Nothing
  Set Tbl = Nothing
  Set dbs = Nothing
  Exit Sub
err_trap:
 MsgBox "modosuエラー:" & err.Number & " " & err.Description
 Resume exit_here



End Sub


Private Sub main()
Dim dbs As Database
Dim Tbl As TableDef
Dim qdf As QueryDef
Dim tblName, NewName As String

Const changeTable = "t_changetable"
Dim Aruyo As Boolean

On Error GoTo err_trap

Set dbs = CurrentDb
Aruyo = False


For Each Tbl In dbs.TableDefs
  If Tbl.Name = changeTable Then
     Aruyo = True
    Exit For
  End If
Next Tbl
     
If (Aruyo) Then
  dbs.TableDefs.Delete changeTable
End If

Call CreateTable

For Each Tbl In dbs.TableDefs
  tblName = Tbl.Name
  If Left(tblName, 4) <> "MSys" And Left(tblName, 4) <> "~TMP" Then
  
    If Left(tblName, 2) <> "t_" Then
     NewName = "t_" & tblName
     Call AppendTable(tblName, NewName)
    End If
  End If
Next Tbl

Call AlterTableAndMakeQ

Application.RefreshDatabaseWindow
exit_here:

 Set dbs = Nothing
 Set Tbl = Nothing
 Exit Sub

err_trap:
 MsgBox "mainエラー:" & err.Number & " " & err.Description
 Resume exit_here

End Sub