Views

Histats

Vitrine

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.
del.icio.us

✔ VBA Brazil®

✔ VBA Brazil®
brazilsalesforceeffectiveness@gmail.com
Related Posts Plugin for WordPress, Blogger...
diHITT - Notícias