Hi Ken,
Save the following code in a module.
Run Debug to check for wordwrap probs.
Import Excel data into a table (say "tblKenSS")
Sub expects only the 2 text "preserve fields"
and rest of fields to be Long in this "FromTable."
Sub will accept query name, so if import brings
more than these fields, make a query where you
get only these fields (or depending on your Excel
file, you may just need to create a query against
the Excel file instead of importing).
Then run following sub in Immediate Window
(something like following):
fImportToThinTablePreserve2Fields "tblKenSS","tblThin","Item","Size"
'********* 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(pPreserveField1
& "")) > 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
With rsTo
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
End With
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 ***********
good luck,
gary
