"Brian"wrote:
I wonder if anyone can offer some advice on acheiving an end result. I
have
data which comes from a database in the format:
Date AdvisorName Type1Sales Type2Sales
Type3Sales
10/11/2007 Brian Thomson 5 3
2
This information is then stored into another database in the format:
Date AdvisorName SalesType Sales
10/11/2007 Brian Thomson Type1Sales 5
10/11/2007 Brian Thomson Type2Sales 3
10/11/2007 Brian Thomson Type3Sales 2
It is almost like a pivot table but I would then append this data to
another
database table in the format above.
Hi Brian,
This has worked for me before to preserve
2 fields in a "wide" table/query, but go "thin"
on the other number fields.
Save the following code in a module.
Run Debug to check for wordwrap probs.
Sub expects only the 2 text "preserve fields"
and rest of fields to be Long in this "FromTable."
Sub will accept a query name, so might be best to
use a query on your "wide" table to alias "Date"
to a non-reserved field name (say "SalesDate"), i.e.,
qryWideSales
SELECT
Format([Date],"mm/dd/yyyy") As SalesDate,
AdvisorName,
Type1Sales,
Type2Sales,
Type3Sales
FROM yurtable;
Note: as sub is written, date will end up as Text!
if you expect to save Time portion, then
adjust format() of qryWideSales, i.e.,
Format([Date],"mm/dd/yyyy nn:ss AM/PM") As SalesDate,
You'll have to convert back to Date/Time afterwards (or rewrite sub).
Then run following sub in Immediate Window
(something like following):
fImportToThinTablePreserve2Fields
"qryWideSales","tblThin","SalesDate","AdvisorName"
'********* code start *************
Public Sub fImportToThinTablePreserve2Fields( _
pFromTable As Variant, _
pToTable As Variant, _
pPreserveField1 As Variant, _
pPreserveField2 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 strPreserve1 As String
Dim strPreserve2 As String
Dim lngPreserveFieldCnt As Long
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 pPreserveField1 and pPreserveField2?
If Len(Trim(pPreserveField1 & "")) > 0 _
And Len(Trim(pPreserveField2 & "")) > 0 Then
strSQL = "CREATE TABLE " & pToTable & " (ID AUTOINCREMENT, " _
& "FldPreserve1 TEXT, FldPreserve2 TEXT, FldName TEXT, " _
& "FldValue LONG, " _
& "CONSTRAINT PK_ID PRIMARY KEY (ID ));"
'Debug.Print strSQL
CurrentDb.Execute strSQL, dbFailOnError
Else
'no Preserve field
MsgBox "Please provide names of both 'Preserve Fields.'"
GoTo Exit_fImportToThinTablePreserveField
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)
'get values of preserve fields
lngPreserveFieldCnt = 0
For i = 0 To rsFrom.Fields.Count - 1
If rsFrom.Fields(i).Name = pPreserveField1 Then
strPreserve1 = rsFrom.Fields(i) & ""
lngPreserveFieldCnt = lngPreserveFieldCnt + 1
Else
If rsFrom.Fields(i).Name = pPreserveField2 Then
strPreserve2 = rsFrom.Fields(i) & ""
lngPreserveFieldCnt = lngPreserveFieldCnt + 1
Else
If lngPreserveFieldCnt = 2 Then Exit For
End If
End If
Next i
'save record in thin table
For i = 0 To rsFrom.Fields.Count - 1
With rsTo
If rsFrom.Fields(i).Name <> pPreserveField1 _
And rsFrom.Fields(i).Name <> pPreserveField2 _
And rsFrom.Fields(i) <> 0 Then
.AddNew
!FldPreserve1 = strPreserve1
!FldPreserve2 = strPreserve2
!FldName = rsFrom.Fields(i).Name
!FldValue = rsFrom.Fields(i)
.Update
Else
End If
End With
Next i
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
'***** code end ***********
