✔ Programação GLOBAL®: VBA Access - Função para transpor a tabela.

VBA Access - Função para transpor a tabela.

Access 2002

Às vezes, talvez seja necessário transpor os dados em uma tabela ou consulta de modo que os nomes dos campos sejam listados verticalmente na coluna à esquerda e que os dados sejam distribuídos pela página horizontalmente. Por exemplo, talvez seja necessário transpor os dados de um relatório ou antes exportá-los para um arquivo de texto.

O Método a seguir mostra como é possível usar um procedimento VBA (Visual Basic for Applications) para cumprir a tarefa.

OBSERVAÇÃO: Esse método não funcionará se você tiver mais de 255 registros, pois o número máximo de campos em uma tabela do Microsoft Access é 255.

Crie um novo módulo no banco de dados e digite ou cole o seguinte procedimento:

Function Transposer(strSource As String, strTarget As String)

    Dim db As DAO.Database
   Dim tdfNewDef As DAO.TableDef
   Dim  fldNewField As DAO.Field
   Dim rstSource As DAO.Recordset, rstTarget As  DAO.Recordset
   Dim i As Integer, j As Integer

   On Error GoTo  Transposer_Err

   Set db = CurrentDb()
   Set rstSource =  db.OpenRecordset(strSource)
   rstSource.MoveLast

   ' Create a new  table to hold the transposed data.
   ' Create a field for each record in the  original table.
   Set tdfNewDef = db.CreateTableDef(strTarget)
   For i =  0 To rstSource.RecordCount
      Set fldNewField =  tdfNewDef.CreateField(CStr(i + 1), dbText)
      tdfNewDef.Fields.Append  fldNewField
   Next i
   db.TableDefs.Append tdfNewDef


   '  Open the new table and fill the first field with
   ' field names from the  original table.
   Set rstTarget = db.OpenRecordset(strTarget)
   For i =  0 To rstSource.Fields.Count - 1
      With rstTarget
        .AddNew
         .Fields(0) = rstSource.Fields(i).Name
        .Update
      End  With
   Next i

   rstSource.MoveFirst
   rstTarget.MoveFirst
    ' Fill each column of the new table
   ' with a record from the original  table.
   For j = 0 To rstSource.Fields.Count - 1
      ' Begin with the  second field, because the first field
      ' already contains the field  names.
      For i = 1 To rstTarget.Fields.Count - 1
         With  rstTarget
            .Edit
            .Fields(i) =  rstSource.Fields(j)
            rstSource.MoveNext
             .Update
         End With

      Next i
       rstSource.MoveFirst
      rstTarget.MoveNext
   Next j

    db.Close

   Exit Function

Transposer_Err:

   Select Case  Err
      Case 3010
         MsgBox "The table " & strTarget & "  already exists."
      Case 3078
         MsgBox "The table " &  strSource & " doesn't exist."
      Case Else
         MsgBox  CStr(Err) & " " & Err.Description
   End Select

   Exit  Function

End Function

Para testar a função, pressione CTRL+G. Na janela Imediato, digite a seguinte linha e pressione ENTER:

? Transposer("Suppliers","SuppliersTrans")

André Luiz Bernardes
A&A - WORK, DON´T PLAY!
http://al-bernardes.sites.uol.com.br/
bernardess@gmail.com

+55 (13) 9152-2565

Twitter: @officespecialis
@brzexceldevelop
@brzaccessdevel

Esta mensagem pode conter informação confidencial e/ou privilegiada. Se você não for o destinatário ou a pessoa autorizada a receber esta mensagem, não pode usar, copiar ou divulgar as informações nela contidas ou tomar qualquer ação baseada nessas informações. Se você recebeu esta mensagem por engano, por favor avise imediatamente o remetente, respondendo o e-mail e em seguida apague-o. Agradecemos sua cooperação.