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
spreadsheets.
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
below.
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),
vbProperCase))
'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
Else
ExistList = ExistField.Name
End If
Next ExistField
.Close
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
.MoveFirst
'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 & "ADD COLUMN "
MySQL = MySQL & NewField
MySQL = MySQL & " TEXT"
MyDB.Execute (MySQL), dbFailOnError
Else
'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
Else
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)
SkipField:
Next fld
.Close
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 & "SELECT "
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
Else
'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
.AddNew
!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
.Update
End With
Me.Refresh
'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
Loop
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
fDeleteTempTables
End If
End Sub
--
TIA,
Don
=============================
Use My*****@Telus.Net for e-mail
Disclaimer:
Professional PartsPerson
Amateur Database Programmer {:o)
I'm an Access97 user, so all posted code
samples are also Access97- based
unless otherwise noted.
=============================
