Jenny said:
I have a table with financial data that has column headings as Months, and
the first row contains the description eg.
Jan Feb Mar
Salary 1000 500 3000
PAYE 50 40 70
Is there a query I can do to change the data to look like this:
Salary Jan 1000
PAYE Jan 50
Salary Feb 500
PAYE Feb 40 etc.
Hi Jenny,
Start a new module.
Copy the following code
and paste in your new module.
Save the module (say as "modUtil").
If you are not sure, click on "References"
in top menu and make sure you have
DAO in references.
Then click on Debug and Compile
in top menu to make sure did not
have word-wrap problems.
To test, if your table above were named "tblT"
and the fieldname of the first column (that you
want to "preserve") were "Col1"
In Immediate window at bottom, type
fImportToThinTablePreserveField "tblT","tblThin","Col1"
'**** start of code ***
Option Explicit
Public Sub fImportToThinTablePreserveField(pFromTable As Variant, _
pToTable As Variant, _
Optional pPreserveField
As Variant)
On Error GoTo Err_fImportToThinTablePreserveField
Dim rsFrom As DAO.Recordset
Dim rsTo As DAO.Recordset
Dim Response, strMsg As String, varReturn
Dim strSQL As String
Dim strPreserve As String
Dim lngVal As Long
Dim lngRecNum As Long, i As Long
'check that pFromTable is not null nor ZLS
If Len(Trim(pFromTable & "")) > 0 Then
'check that pToTable is not null nor ZLS
If Len(Trim(pToTable & "")) > 0 Then
'continue processing
Else
MsgBox "Please provide name of thin table " _
& "you wish to fill with number data."
GoTo Exit_fImportToThinTablePreserveField
End If
Else
MsgBox "Please provide name of wide table " _
& "with many number fields."
GoTo Exit_fImportToThinTablePreserveField
End If
strMsg = "Will be importing number data from the following table:" _
& vbCrLf & vbCrLf & pFromTable & vbCrLf & vbCrLf _
& "into the following thin table:" _
& vbCrLf & vbCrLf & pToTable
Response = MsgBox(strMsg, vbOKCancel)
If Response = vbCancel Then ' User chose to Cancel
GoTo Exit_fImportToThinTablePreserveField
End If
DoCmd.Hourglass True
'delete pToTable if it exists
If TableExists(CStr(pToTable)) Then
'if it exists, delete it
CurrentDb.Execute "DROP TABLE " & pToTable, dbFailOnError
End If
'recreate pToTable
'do we have a pPreserveField?
If Not IsMissing(pPreserveField) Then
strSQL = "CREATE TABLE " & pToTable & " (ID AUTOINCREMENT, " _
& "FldPreserve TEXT, FldName TEXT, FldValue LONG, " _
& "CONSTRAINT PK_ID PRIMARY KEY (ID ));"
'Debug.Print strSQL
CurrentDb.Execute strSQL, dbFailOnError
Else
'no Preserve field
strSQL = "CREATE TABLE " & pToTable & " (ID AUTOINCREMENT, " _
& "FldName TEXT, FldValue TEXT, " _
& "CONSTRAINT PK_ID PRIMARY KEY (ID ));"
'Debug.Print strSQL
CurrentDb.Execute strSQL, dbFailOnError
End If
Set rsFrom = CurrentDb.OpenRecordset(pFromTable, dbOpenDynaset)
'quit if empty table
If rsFrom.EOF = True Then
rsFrom.Close
MsgBox pFromTable & " does not contain any records.", vbCritical
GoTo Exit_fImportToThinTablePreserveField
Else
'continue
End If
Set rsTo = CurrentDb.OpenRecordset(pToTable, dbOpenDynaset)
rsFrom.MoveFirst
lngRecNum = 0
Do While Not rsFrom.EOF
lngRecNum = lngRecNum + 1
'****** update progress display in status bar *****************
varReturn = SysCmd(acSysCmdSetStatus, "Processing Rec # " &
lngRecNum)
'did we have a pPreserveField?
If Not IsMissing(pPreserveField) Then
'get value of preserve field
For i = 0 To rsFrom.Fields.Count - 1
With rsTo
If rsFrom.Fields(i).Name = pPreserveField Then
strPreserve = rsFrom.Fields(i) & ""
Exit For
Else
End If
End With
Next i
'save record in thin table
For i = 0 To rsFrom.Fields.Count - 1
With rsTo
If rsFrom.Fields(i).Name <> pPreserveField Then
.AddNew
!FldPreserve = strPreserve
!FldName = rsFrom.Fields(i).Name
!FldValue = rsFrom.Fields(i)
.Update
Else
End If
End With
Next i
Else
'no Preserve field
For i = 0 To rsFrom.Fields.Count - 1
With rsTo
.AddNew
!FldName = rsFrom.Fields(i).Name
!FldValue = CStr(rsFrom.Fields(i) & "")
.Update
End With
Next i
End If
rsFrom.MoveNext
Loop
'clear display in status bar
varReturn = SysCmd(acSysCmdClearStatus)
'close recordsets
rsFrom.Close
rsTo.Close
MsgBox "Have successfully imported number data from " & vbCrLf _
& pFromTable & vbCrLf & " into table " & vbCrLf & pToTable & "."
Exit_fImportToThinTablePreserveField:
DoCmd.Hourglass False
Set rsFrom = Nothing
Set rsTo = Nothing
Exit Sub
Err_fImportToThinTablePreserveField:
MsgBox Err.Description
Resume Exit_fImportToThinTablePreserveField
End Sub
Public Function TableExists(strTableName As String) As Boolean
'from Joe Fallon
On Error Resume Next
TableExists = IsObject(CurrentDb.TableDefs(strTableName))
End Function
'*** end of code ***
