Importing non-contiguous ranges from Excel

[dkmoreland]

[SOLVED] Importing non-contiguous ranges from Excel

This is actually a two part question - I need to import several fields from an Excel spreadsheet that is generated from another program. The spreadsheet is always on the user's personal mapped drive - call it the U: drive, since all the mapping is the same.

This spreadsheet is formatted in such a way that does not lend itself to easy importing. All of the cells are named (JobID, JobDesc, etc). I need to import about a dozen non-contiguous cells into a single existing table. These imports will only contain one record each time.

I would also like to provide a button to bring up the file dialog specifically for the U: drive that lists only the Excel files. Then when the user selects their file, it will do the import.

So, specifically, here are my questions:

• How can I bring up a file dialog that will default to their user drive?

• Can the Transfer Spreadsheet method import non-contiguous ranges into the same table?

• If not, is there a way around it?

I have spent a few hours searching forums for an answer but haven't found a method that I can make work.

Any advice would be very much appreciated.

 

[Pat Hartman]

Here's a function to bring up the file picker. The .InitialFileName sets where the dialog opens and the .Filters specify the file extensions.

Public Function fChooseFile()
  
   ' Requires reference to Microsoft Office xx.0 Object Library.
 
   Dim fDialog As Office.FileDialog
   Dim varFile As Variant
 
 
   ' Set up the File Dialog.
   Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
 
   With fDialog
 
      ' Allow user to make multiple selections in dialog box
      .AllowMultiSelect = False
             
      ' Set the title of the dialog box.
      .Title = "Please select one file"
 
      'starting location
      .InitialFileName = CurrentProject.path
      
      ' Clear out the current filters, and add our own.
      .Filters.Clear
      .Filters.Add "Excel ", "*.XLSX"
''''      .Filters.Add "Access Databases", "*.MDB"
''''      .Filters.Add "Access Projects", "*.ADP"
      .Filters.Add "All Files", "*.*"
 
      ' Show the dialog box. If the .Show method returns True, the
      ' user picked at least one file. If the .Show method returns
      ' False, the user clicked Cancel.
      If .Show = True Then
         'Loop through each file selected and add it to our list box.
         For Each varFile In .SelectedItems
            fChooseFile = varFile
''''            Me.FileList.AddItem varFile
         Next
        
      Else
         MsgBox "You clicked Cancel in the file dialog box."
      End If
   End With

End Function

No. TransferSpreadsheet only works on table type data. You need to use OLE automation.

However, if you have control over the template, you can add a tab that pulls all the data into a single row with a row of column headings above. Then you can use TransferSpreadsheet to import that sheet.

 

[dkmoreland]

Thanks for the function. So do I need to plug this code into a module and call the function from the button click subroutine?

Also, I've not used OLE automation. Can anybody point me to a good source so I can learn about it?

Thanks

 

[dkmoreland]

I'm still stuck on this - does anybody have any suggestions about how to import non-contiguous cells?

 

[dkmoreland]

Here's a new question - if I use TransferSpreadsheet to import one named cell at a time into a bunch of temp tables, how can I go about moving the data in those fields in the temp table to the actual table I need to update? This spreadsheet only has one record in it at a time but there are about a dozen named fields.

I hope my explanation makes sense.

Thanks for the help.

 

[CJ_London]

think we need to see an example of what you are trying to import as an excel sheet to understand what 'non-contiguous cells' really means. Also to understand if these cells are always in the same location on the worksheet

if I use TransferSpreadsheet to import one named cell at a time into a bunch of temp tables, how can I go about moving the data in those fields in the temp table to the actual table I need to update?

it can be done, but again, depends. if doing this a cell at a time, they could go into a table with two fields - the cell name and the cell value. Then use a crosstab query to pivot into a row

 

[dkmoreland]

I've attached a screenshot - the highlighted fields are the ones I need to import. The spreadsheet is always in this format and the information pertains to only one record. The names of the cells do not change.

Thanks.

 

[CJ_London]

have concerns about the values towards the bottom - are there always 3, or at least no more than 3?

could be multiple imports per my last post could be the way to go or

you could perhaps import this to a temp table of all text fields - looks like 6 fields/columns

then a series of queries - something like

select field6 FROM tmptable WHERE field5='Job'
select field2 FROM tmpTable WHERE field1='Description'
etc

which can be combined in a separate query (with no joins)

 

[dkmoreland]

The number of values towards the bottom - the bulk items - will be tricky. There are not always three - sometimes there is just one, sometimes there are none. If there are more than one, I'll have do some tricky concatenation because I'll need them all in the same field.

For clarification purposes, I've attached a spreadsheet that shows the field mapping and data types.

I'll start off with the multiple import and crosstab query that you suggested and see how far I get.

If you think of anything else, please let know. Thank you so much for the help so far.

Diana

 

[dkmoreland]

Here's a function to bring up the file picker. The .InitialFileName sets where the dialog opens and the .Filters specify the file extensions.

When I call this fChooseFile function, I get a compile error - user -defined type not defined.

It crashes here:

 Dim fDialog As Office.FileDialog

Am I missing a declaration somewhere?

 

[Pat Hartman]

So do I need to plug this code into a module and call the function from the button click subroutine?

Yes

I took out most of the extraneous code. I hope I left enough so you can see what you need to do.

Private Sub cmdBrowse_Click()
Dim appExcel As Excel.Application
Dim wbk As Excel.Workbook
Dim wks As Excel.Worksheet
Dim FileName As String
Dim FirstSeparator As Integer
Dim db As DAO.Database
Dim Td As DAO.TableDef
Dim tdDefaults As DAO.TableDef
Dim rs As DAO.Recordset
Dim rsDefaults As DAO.Recordset
Dim strMsg As String
Dim strSQL As String
Dim strJobDesc As String
Dim strJobPrefix As String
Dim strDetWhere As String
Dim strFabWhere As String
Dim strEreWhere As String
Dim strDetPerHr As Currency
Dim strFabPerHr As Currency
Dim strErePerHr As Currency
On Error GoTo ErrProc
    Set db = CurrentDb()

    Me.txtFileName = fChooseFile()
    If Me.txtFileName = "" Then
        Exit Sub
        Msgbox "Please select a file.",vbokOnly
    End If

    Set Td = db.TableDefs!tblBids
    Set rs = Td.OpenRecordset
    Set tdDefaults = db.TableDefs!tblDefaults
    Set rsDefaults = tdDefaults.OpenRecordset
    
    'open spreadsheet (Input Sheet) page, get data from specific cells
    Set appExcel = Excel.Application
    Set wbk = appExcel.Workbooks.Open(Me.txtFileName)
    strJobDesc = Range("'PM Misc Sheet'!E3").Value
    strDetWhere = Range("'M040133'!F1").Value
    strFabWhere = Range("'M040133'!F2").Value
    strEreWhere = Range("'M040133'!F3").Value
    strDetPerHr = Range("'M040133'!D1").Value
    strFabPerHr = Range("'M040133'!D2").Value
    strErePerHr = Range("'M040133'!D3").Value
    'close excel
    wbk.Close (False)   'close without saving changes
    appExcel.Quit
    Set wbk = Nothing
    Set appExcel = Nothing
    
    rs.AddNew
        rs!JobNum = Me.txtJobNum
        rs!JobType = "Misc"
        rs!JobPrefix = strJobPrefix
        rs!ImportWorkbookName = Me.txtFileName
        rs!ImportedBy = Me.txtUserName
        rs!FabPerHr = strFabPerHr
        rs!ErePerHr = strErePerHr
        rs!DetPerHr = strDetPerHr
        rs!FabWhere = strFabWhere
        rs!EreWhere = strEreWhere
        rs!DetWhere = strDetWhere
        rs!FabInHseFactor = rsDefaults!FabInHseFactor
        rs!EreInHseFactor = rsDefaults!EreInHseFactor
        rs!DetInHseFactor = rsDefaults!DetInHseFactor
        rs!FabCostCode = rsDefaults!FabCostCode
        rs!EreCostCode = rsDefaults!EreCostCode
        rs!DetCostCode = rsDefaults!DetCostCode
        rs!ErePT = rsDefaults!ErePT
        rs!EreWC = rsDefaults!EreWC
        rs!EreF = rsDefaults!EreF
        rs!JobDesc = strJobDesc
        Me.txtBidID = rs!BidID
    rs.Update
    
    rs.Close

    rsDefaults.Close
    DoCmd.RunMacro "mSetWarningsOff"
    DoCmd.OpenQuery "qAppendMiscEstimates"
    DoCmd.RunMacro "mSetWarningsOn"
    MsgBox "Import Complete", vbOKOnly
    
ExitProc:
    Set db = Nothing
    Exit Sub
ErrProc:
    Select Case Err.Number
        Case 462    'excel not open
            Set appExcel = New Excel.Application
            Resume Next
        Case 3125
            MsgBox "The selected workbook is not the correct format.", vbOKOnly
            Resume ExitProc
        Case 3201
            MsgBox "Job Prefix is not valid.  Please add the new prefix to the prefix list.  Import was cancelled.", vbOKOnly
            Resume ExitProc
        Case Else
            MsgBox Err.Number & "--" & Err.Description
            Resume ExitProc
            Resume Next
    End Select
            
End Sub

 

[Cronk]

To extract data from an area in an Excel sheet where the start and end are unknown, search down the column till the header cell is found and then continue reading cells until a blank line or other delimiter is reached.

intRow = 0  
do
   intRow=Just in case the spreadsheet is missing the header
   if intRow > 5000 then
     msgbox "Problem"
     exit do
   endif
until objXL.Cells(intRow,1) = "Materials"   '--This the name of the header in the png supplied by the OP

intRow = intRow + 1     '--skip the next line has the column headings

While objXl.Cells(intRow,1) <>""
   rs!Field1= objXL.Cells(intRow,1)
   rs!Field2= objXL.Cells(intRow,2)
   rs!Field3= objXL.Cells(intRow,3)
   .....
   intRow=inRow+1
loop

 

[dkmoreland]

To extract data from an area in an Excel sheet where the start and end are unknown, search down the column till the header cell is found and then continue reading cells until a blank line or other delimiter is reached.

I'll give that a try! Thanks!

 

[Pat Hartman]

Your locations are known so the code I posted will work.

 

[dkmoreland]

Your locations are known so the code I posted will work.

Yes - I am implementing the changes now. I really appreciate it.

 

[dkmoreland]

I'm bumping into my own ignorance here - I hope you folks are willing to educate me.

The form has a "Select File to Import" button that runs this code:

 Private Sub CmdPickFile_Click()

    strInitialDir = "U:\"
    Me.TextImport = Nz(GetOpenFile(strInitialDir, "Select File"), "")

End Sub

The Text field populates with the file name, then the user clicks the Import button, which runs this:

 Private Sub CmdImport_Click()

Dim appExcel As Excel.Application
Dim wbk As Excel.Workbook
Dim wks As Excel.Worksheet
Dim FileName As String
Dim FirstSeparator As Integer
Dim db As DAO.Database
Dim Td As DAO.TableDef
Dim tdDefaults As DAO.TableDef
Dim rs As DAO.Recordset
Dim rsDefaults As DAO.Recordset
Dim strMsg As String
Dim strSQL As String
Dim strJob As String
Dim strSubJob As String
Dim strPress As String
Dim strDescription As String
Dim strCustomer As String
Dim strTechnology As String
Dim lngOrderPieces As Long
Dim lngLayout As Long
Dim strBulk As String
Dim lngShot As Long



On Error GoTo ErrProc
    Set db = CurrentDb()

    'Me.txtFileName = fChooseFile() - using different function
    StrImportFile = Me.TextImport
    
    
    If Me.TextImport = "" Then
        Exit Sub
        MsgBox "Please select a file.", vbOKOnly
    End If
    
    [COLOR="Red"]Set Td = db.TableDefs![Job Info]
    Set rs = Td.OpenRecordset
    Set tdDefaults = db.TableDefs!tblDefaults
    Set rsDefaults = tdDefaults.OpenRecordset[/COLOR]
    
    'open spreadsheet (Input Sheet) page, get data from specific cells
    Set appExcel = Excel.Application
    Set wbk = appExcel.Workbooks.Open(Me.TextImport)
    strJob = Range("'RunTicket'!P3").Value
    strSubJob = Range("'RunTicket'!P4").Value
    strPress = Range("'RunTicket'!P5").Value
    strDescription = Range("'RunTicket'!E8").Value
    strCustomer = Range("'RunTicket'!H9").Value
    strTechnology = Range("'RunTicket'!H12").Value
    lngOrderPieces = Range("'RunTicket'!E16").Value
    lngLayout = Range("'RunTicket'!P25").Value
    strBulk = Range("'RunTicket'!B30").Value
    lngShot = Range("'RunTicket'!N30").Value
    
    'close excel
    wbk.Close (False)   'close without saving changes
    appExcel.Quit
    Set wbk = Nothing
    Set appExcel = Nothing
    
    rs.AddNew
        rs![Job #] = strJob + "-" + strSubJob
        rs!Press = strPress
        rs![Job Name] = strDescription
        'rs!ImportWorkbookName = Me.txtFileName
        'rs!ImportedBy = Me.txtUserName
        rs![Customer Name] = strCustomer
        rs!Technology = strTechnology
        rs![Order Quantity] = lngOrderPieces
        rs![Labels on Repeat] = lngLayout
        rs![FP / Bulk #] = strBulk
        rs![shot size] = lngShot
        
    rs.Update
    
    rs.Close

    rsDefaults.Close
    
    MsgBox "File " + StrImportFile + " has been imported", vbOKOnly
    
    'MsgBox "Import Complete", vbOKOnly
    
ExitProc:
    Set db = Nothing
    Exit Sub
ErrProc:
    Select Case Err.Number
        Case 462    'excel not open
            Set appExcel = New Excel.Application
            Resume Next
        Case 3125
            MsgBox "The selected workbook is not the correct format.", vbOKOnly
            Resume ExitProc
        Case 3201
            MsgBox "Job Prefix is not valid.  Please add the new prefix to the prefix list.  Import was cancelled.", vbOKOnly
            Resume ExitProc
        Case Else
            MsgBox Err.Number & "--" & Err.Description
            Resume ExitProc
            Resume Next
    End Select
    
End Sub

I suspect there's a problem with the tabledefs - the code jumps to error handling when it gets to code in red above. The [Job Info] table is the table I am trying to import to. I'm not positive the file name is making to the import function and I'm not sure my record set is right for importing to the [Job Info] table. By the way - I know my table and field names are wonky - this is an inherited project.

Can anybody offer any insight as to what I am missing? Pat - this is the code you so kindly provided. How badly have I butchered it?

Thanks!

 

[Pat Hartman]

Which of the four lines is the code stopping on?
What is the exact error message?

Object names with embedded spaces or special characters fail in certain circumstances. I never use them for this reason.

 

[Cronk]

@DKM

I think the syntax you are using is wrong. Look up access vba openrecordset.

Use
set rst = db.openrecordset("yourTableName")
or
set rst = db.openrecordset("select * from yourTableName")

Omit the tabledef lines.

 

[dkmoreland]

Which of the four lines is the code stopping on?
What is the exact error message?

Object names with embedded spaces or special characters fail in certain circumstances. I never use them for this reason.

The debugger stops on the first line shown in red text above. The error message is an Access msgbox that says "3265 - Item not found in this collection". That error makes no sense to me.

 

[Pat Hartman]

I NEVER, EVER use ANY name that includes spaces or special characters. It is amazing the problems they cause when using VBA and queries.

There is another reference style that might work -

Set Td = db.TableDefs("[Job Info]")

I think there is no ! or . before the ( but if the above doesn't work, try adding those characters.