[Resolvido]Adicionar Primary Key em tabela Ordenada a partir de um campo

Bom dia!

Utilizo um código para adicionar um Primary Key em uma tabela importada via código. E esta funcionando a adição.
Mas preciso que a primary key fosse adicionada em ordem crescente seguindo o campo Parcela. E isso não esta acontecendo.

Public Function AbriRC()

' Requer referencia a Microsoft Office 11 Object Library
   On Error GoTo PROC_ERR
   
   Dim fd As FileDialog
   Set fd = Application.FileDialog(msoFileDialogFilePicker)
   
   fd.Title = "Selecione o arquivo base de Protocolo"
   fd.Filters.Add "Base GIS", "*.dbf, *.xlsx", 1

   fd.Show
   
   If (fd.SelectedItems.Count > 0) Then
       '------inicio importação excel para sincronização
       Dim strPathFile As String, strFile As String, strPath As String
       Dim strTable As String
       Dim FileName As String
       Dim Dir1 As String
       Dim blnHasFieldNames As Boolean
       Dim db As DAO.Database
       Dim tbl As DAO.TableDef
       Dim cpo As DAO.Field
       Dim nbTypeFile As Integer
       blnHasFieldNames = True
       Dir1 = Left(fd.SelectedItems(1), (Len(fd.SelectedItems(1)) - Len(strFile)))
       strPathFile = fd.SelectedItems(1)
       strPath = CurrentProject.Path
       strTable = "FromDBF"
       strFile = Dir(fd.SelectedItems(1))
       nbTypeFile = InStr(1, Right(strFile, 5), ".") 'Tipo de Arquivos (1=DBF 2=Excel)
                   
       'MsgBox Left(fd.SelectedItems(1), (Len(fd.SelectedItems(1)) - Len(strFile) - 1)) & " / " & strFile ' Teste
           
             
       'apaga temporarios
       'DoCmd.RunSQL "Delete * from [FromDBF]"
        DoCmd.DeleteObject acTable, strTable

       
       'On Error Resume Next
               
       'importa para tabela local temporária
       'Formato XLSX ACRESCETAR A TABELA EXISTENTE
       'DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, strTable, strPathFile, blnHasFieldNames
       
       
               
       'Formato DBF
       DoCmd.TransferDatabase TransferType:=acImport, DatabaseType:="dBASE III", DatabaseName:=Left(fd.SelectedItems(1), (Len(fd.SelectedItems(1)) - Len(strFile) - 1)), ObjectType:=acTable, Source:=strFile, Destination:=strTable
       On Error GoTo PROC_ERR
       'Ordena campos na talela
       DoCmd.OpenTable strTable
       DoCmd.SetOrderBy "Parcela ASC"
       DoCmd.Save acTable, strTable
       DoCmd.Close acTable, strTable
       CurrentDb.Execute ("Alter Table FromDBF ADD COLUMN cd_id2 AutoIncrement;")
       
                         
       'Formato CSV
       
       'DoCmd.TransferText TransferType:=acImportDelim, _
               TableName:="strTable", hasfieldnames:=True, FileName:=strPathFile
       'DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, strTable, strPathFile, blnHasFieldNames
       
       'sql verifica existentes e marca com não novo
       'DoCmd.OpenQuery "xls01marcaExistentes", acViewNormal, acEdit
       'sql atualiza existentes
       'DoCmd.OpenQuery "xls02AtualizaExistentes", acViewNormal, acEdit
       'sql lança novos no ficheiro funcionarios
       'DoCmd.OpenQuery "xls03LancaNovos", acViewNormal, acEdit
       
       MsgBox "Operação concluída.", vbInformation, ""
       
       'apaga temporarios
       'DoCmd.RunSQL "Delete * from [Dados Coletor]"
       
   Else
       MsgBox "Não foi escolhido nenhum ficheiro", vbInformation, ""
   End If
   
PROC_EXIT:
   Exit Function
   
PROC_ERR:
   DoCmd.Hourglass False
   If Err.Number = 3011 Then
      LocalXML = ""
      MsgBox ("Ficheiro inválido. Verifique se no nome do arquivo existe espaços em branco, algum caractere especial (- / _ & @) ou se o formato do arquivo está correto.")
      'Cria uma tabela
      Set db = CurrentDb
      Set tbl = db.CreateTableDef("FromDBF")
      Set cpo = tbl.CreateField("cData", dbDate)
      tbl.Fields.Append cpo
      db.TableDefs.Append tbl
      db.TableDefs.Refresh
         
   Else
       MsgBox Err.Description
   End If
   Resume PROC_EXIT

End Function

Fernando

Uma ideia que me ocorreu.

Como já sabe adicionar a primary key em uma tabela importada,


sugiro que crie uma consulta de criação de tabela, com o campo parcela ordenado.

então..

E só aplicar a adição da primary key

Que tal?

Noobezinho, Muito obrigado!


Funcionou perfeitamente e me ajudou em uma outra tarefa.

Podemos encerrar o tópico. Vou acrescentar abaixo o código para futuras consultas:

------------------------------------------------------------------------------------------------

Código:


Public Function AbriRC()

' Requer referencia a Microsoft Office 11 Object Library
   On Error GoTo PROC_ERR
   
   Dim fd As FileDialog
   Set fd = Application.FileDialog(msoFileDialogFilePicker)
   
   fd.Title = "Selecione o arquivo base de Protocolo"
   fd.Filters.Add "Base GIS", "*.dbf, *.xlsx", 1

   fd.Show
   
   If (fd.SelectedItems.Count > 0) Then
       '------inicio importação excel para sincronização
       Dim strPathFile As String, strFile As String, strPath As String
       Dim strTable As String
       Dim FileName As String
       Dim Dir1 As String
       'Dim blnHasFieldNames As Boolean
       Dim db As DAO.Database
       Dim tbl As DAO.TableDef
       Dim cpo As DAO.Field
       Dim nbTypeFile As Integer
       'blnHasFieldNames = True
       Dir1 = Left(fd.SelectedItems(1), (Len(fd.SelectedItems(1)) - Len(strFile)))
       strPathFile = fd.SelectedItems(1)
       strPath = CurrentProject.Path
       strTable = "FromDBF"
       strFile = Dir(fd.SelectedItems(1))
       nbTypeFile = InStr(1, Right(strFile, 5), ".") 'Tipo de Arquivos (1=DBF 2=Excel)
                   
       'MsgBox Left(fd.SelectedItems(1), (Len(fd.SelectedItems(1)) - Len(strFile) - 1)) & " / " & strFile ' Teste
           
             
       'apaga temporarios
       'DoCmd.RunSQL "Delete * from [FromDBF]"
        DoCmd.DeleteObject acTable, strTable

       
       'On Error Resume Next
               
       'importa para tabela local temporária
       'Formato XLSX ACRESCETAR A TABELA EXISTENTE
       'DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, strTable, strPathFile, blnHasFieldNames
       
       
               
       'Formato DBF Importando dados
       DoCmd.TransferDatabase TransferType:=acImport, DatabaseType:="dBASE III", DatabaseName:=Left(fd.SelectedItems(1), (Len(fd.SelectedItems(1)) - Len(strFile) - 1)), ObjectType:=acTable, Source:=strFile, Destination:=strTable
       
       'Executando Consultas Criar Tabela e inserindo as chaves primárias
[color=#0033ff][b]        DoCmd.SetWarnings (WarbingsOff)
         DoCmd.OpenQuery "CriarTalhao", acViewNormal, acEdit
        CurrentDb.Execute ("Alter Table BaseTalhao ADD COLUMN cd_id1 AutoIncrement;")
        DoCmd.OpenQuery "CriarParcelas", acViewNormal, acEdit
        CurrentDb.Execute ("Alter Table BaseParcelas ADD COLUMN cd_id2 AutoIncrement;")
        DoCmd.SetWarnings (WarbingsOn)[/b][/color]
           
       
                 
       'Formato CSV
       
       'DoCmd.TransferText TransferType:=acImportDelim, _
               TableName:="strTable", hasfieldnames:=True, FileName:=strPathFile
       'DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, strTable, strPathFile, blnHasFieldNames
       
       'sql verifica existentes e marca com não novo
       'DoCmd.OpenQuery "xls01marcaExistentes", acViewNormal, acEdit
       'sql atualiza existentes
       'DoCmd.OpenQuery "xls02AtualizaExistentes", acViewNormal, acEdit
       'sql lança novos no ficheiro funcionarios
       'DoCmd.OpenQuery "xls03LancaNovos", acViewNormal, acEdit
       
       MsgBox "Operação concluída.", vbInformation, ""
       
       
       'apaga temporarios
       'DoCmd.RunSQL "Delete * from [Dados Coletor]"
       
   Else
       MsgBox "Não foi escolhido nenhum ficheiro", vbInformation, ""
   End If
   
PROC_EXIT:
   Exit Function
   
PROC_ERR:
   DoCmd.Hourglass False
   If Err.Number = 3011 Then
      LocalXML = ""
      MsgBox ("Ficheiro inválido. Verifique se no nome do arquivo existe espaços em branco, algum caractere especial (- / _ & @) ou se o formato do arquivo está correto.")
      'Cria uma tabela
      Set db = CurrentDb
      Set tbl = db.CreateTableDef("FromDBF")
      Set cpo = tbl.CreateField("cData", dbDate)
      tbl.Fields.Append cpo
      db.TableDefs.Append tbl
      db.TableDefs.Refresh
         
   Else
       MsgBox Err.Description
   End If
   Resume PROC_EXIT
   

End Function


Fernando

Que bom que pude ajudar!

Valeu pelo retorno!

Boa sorte!