469,927 Members | 1,866 Online
Bytes | Developer Community
New Post

Home Posts Topics Members FAQ

Post your question to a community of 469,927 developers. It's quick & easy.

Renaming a field based on content

Hi Folks,

I have been given a CD with approx 130 .xls files (bean-counters!) that I
would like to import and merge to ONE table (tblTradeshow).

The XL files are *similarly*, but not identically structured, and the first
row does NOT contain field names.

Some (actually most) of the column names *are* the same in all of the

Some sheets have additional columns for extra data (core deposit value, case
qtys, container size, etc), none of which I *really* need, but would like to
preserve if possible.

All sheets contain several blank columns and rows. Some of the blank columns
are between colums of data that I need.

I'm attempting to rename the fields in newly created tables according to
what I can find in each "Column Heading" (which is not on the first row)
Renaming the fields (common denominator approach) is the first step in
appending them to a single table.

The problem that I am running into, I have discovered, is that you cannot
change the field names while you have the recordset open, so I have
"kludged" a solution by creating duplicate tables at run time and modifying
them... so now I have 260 seperate tables!

I have succesfully automated the import and merge procedure , using the code
After this is completed, I am using a function to delete all of those 260
"temp" tables.

All of this code *does* seem to do the job ... but all of these variables,
recordsets, looping, and deletion seems to be redundant.
Can anyone suggest a better way to do this?

Or should I just leave it alone, and be happy that it works? :)

TIA, Don

================================================== ============
Private Sub cmdImportMergeXL_Click()

Dim MyDB As DAO.Database
Set MyDB = CurrentDb
Dim rst As DAO.Recordset

Dim rstFiles As DAO.Recordset
Set rstFiles = MyDB.OpenRecordset("tblFileNames")

Dim MyDir As String
Dim MyFile As String
Dim MyPath As String
Dim FileSpec As String

Dim Pos As Integer
Dim strTableName As String
Dim blnAccepted As Boolean
Dim MySQL As String

Dim Msg As String
Dim CR As String
CR = vbCrLf

Dim OldField As String
Dim NewField As String
Dim ExistField As Field
Dim ExistList As String
Dim rstExist As DAO.Recordset

'Start by browsing for the drive/directory containing the XL files
MyDir = BrowseFolder("Find the directory containing the desired files")

FileSpec = MyDir & "\*.xls"
MyPath = MyDir & "\" & Dir(FileSpec)
MyFile = Dir(FileSpec)
'This section loops thru the files in the directory one at a time
'and performs the import operations
Do While Len(MyFile) > 0
Pos = InStr(1, MyFile, "store") 'eg F:\Bodyshop Products\Bodypro
coveralls store.xls
strTableName = "tbl" & StripString(StrConv(Mid(MyFile, 1, Pos - 1),
'Result: "tblBodyproCoveralls
DoCmd.TransferSpreadsheet , acSpreadsheetTypeExcel97, strTableName,
MyPath, False

'We cannot modify the table that we are importing because we
'have an open recordset, so I make a duplicate copy that I can
'mess around with.
DoCmd.CopyObject , strTableName & "1", acTable, strTableName

Set rstExist = MyDB.OpenRecordset("tblTradeshow", dbOpenTable)
'Build a list of existing "tblTradeshow" fields.
'This code needs to be placed here so that this list
'gets refreshed between each table import operation.
With rstExist
For Each ExistField In rstExist.Fields
If Len(ExistList) > 0 Then
ExistList = ExistList & ", " & ExistField.Name
ExistList = ExistField.Name
End If
Next ExistField
End With

'This section deals with the problem of naming the imported
'table fields. Unfortunately, the first row of the spreadsheet
'did not contain field names, so we have to hunt them down...
Set rst = MyDB.OpenRecordset(strTableName, dbOpenDynaset)
Dim fld As Field
Dim fldName As String
Dim fldList As String
fldList = ""

With rst
.MoveLast 'Populate the Recordset
'Find the row that contains the field names, by searching for
'a product "Line" ... a 3-letter code that identifies the mfr.
.FindFirst "F1 = 'Line'"
For Each fld In .Fields

OldField = fld.Name
NewField = StripString(fld.Value) 'Remove spaces and
punctuation from field name

Select Case NewField
Case "Part"
NewField = "PartNumber"
Case "" '(blank)
GoTo SkipField
Case Else

'If we find a new field name that is not already
'in tblTradeshow, we decide if we want to add it.
If InStr(1, ExistList, NewField) < 1 Then
Msg = ""
Msg = Msg & strTableName
Msg = Msg & " contains: "
Msg = Msg & NewField & CR
Msg = Msg & "where I'm expecting a field name" & CR
& CR
Msg = Msg & "Do you want to use this as the field
name? "

If MsgBox(Msg, vbYesNo) = vbYes Then
'This is where the field name actually
'gets added to tblTradeshow
MySQL = ""
MySQL = MySQL & "ALTER TABLE tblTradeshow "
MySQL = MySQL & NewField
MyDB.Execute (MySQL), dbFailOnError
'User decides NOT to add this field.
GoTo SkipField
End If
End If
End Select

'Build a list of field names
'for the table being imported.

If Len(fldList) > 0 Then
fldList = fldList & ", " & NewField
fldList = NewField
End If

'Now call a function that renames the fields
'(in the duplicate table)to the field names
'that we have found above.
Call fSetFieldName(strTableName & "1", OldField, NewField)
Next fld

End With
Set rst = Nothing
'Now that we have checked / changed /added fieldnames we can transfer
'(merge) the data into a common table ("tblTradeshow")

If Len(fldList) > 0 And InStr(1, fldList, "RegCJ") > 0 Then
'Eliminate empty ROWS
MySQL = ""
MySQL = MySQL & "INSERT INTO tblTradeshow ( "
MySQL = MySQL & fldList
MySQL = MySQL & " ) "
MySQL = MySQL & fldList
MySQL = MySQL & " FROM ["
MySQL = MySQL & strTableName
MySQL = MySQL & "1] "
MySQL = MySQL & "WHERE (((IsNumeric([RegCJ]))=True));"
'Debug.Print MySQL
MyDB.Execute MySQL, dbFailOnError
blnAccepted = True

'Debug.Print MySQL
Msg = ""
Msg = Msg & strTableName
Msg = Msg & " has no valid fieldnames, and will be skipped."
MsgBox (Msg)
blnAccepted = False
End If
'Add the imported filenames to the table
With rstFiles
!FilePath = "#file://" & MyPath & "#"
'This converts the filepath string to a hyperlink,
'which allows the user to open the XL file from a subform link
'for diagnostic / compatison reasons ... "Show Me!"
!Imported = blnAccepted
End With

'There are 2 subforms on this form ... both based on "tblFileNames"
' "sbfFilesImported" shows successful imports
' "sbfFilesRejected" shows failed attempts. (Import fails if no Line
Code is found.)
MyFile = Dir 'Import the next XL file in the directory.

If Len(MyFile) > 0 Then
MyPath = MyDir & "\" & MyFile
End If

Set rstFiles = Nothing
Set rstExist = Nothing
Set rst = Nothing
Set MyDB = Nothing

Msg = ""
Msg = Msg & "XL Data import completed." & CR & CR
Msg = Msg & "Would you like to delete the TEMPORARY tables?"

If MsgBox(Msg, vbYesNo, "Confirm Deletion") = vbYes Then
End If

End Sub

Use My*****@Telus.Net for e-mail
Professional PartsPerson
Amateur Database Programmer {:o)

I'm an Access97 user, so all posted code
samples are also Access97- based
unless otherwise noted.
Nov 12 '05 #1
1 3128
Cloning recordsets would help you eliminate duplicate tabledefs.

Dim db as Database
Dim rec as DAO.RecordSet
Dim strNewFieldName as String

Set db = CurrentDB()
Set rec = db.Openrecordset(<<<YOUR TABLE HERE>>>)

With rec
Call FieldChanger(strNewFieldName)
Nov 12 '05 #2

This discussion thread is closed

Replies have been disabled for this discussion.

Similar topics

1 post views Thread by Don Leverton | last post: by
By using this site, you agree to our Privacy Policy and Terms of Use.