Difficult (solvable?) problem

[usr_X]

I have a continuous form in Microsoft Access and I want to be able to copy data from it like one would copy from a spreadsheet (or datasheet view in Access 2007), i.e. being able to select and copy any combination of rows and columns. If you can figure this out... Help is appreciated.

 

[boblarson]

Not possible to do like Excel, sorry. You could use a multi-select listbox but not a subform to do this.

 

[CraigWarmy]

I have a continuous form and I want to be able to copy data from it like one would copy from a spreadsheet (or datasheet view in Access 2007), i.e. being able to select and copy any combination of rows and columns. If you can figure this out... Help is appreciated.

Make a reference to the Microsoft.Excel. Here's my spreadsheet code:
Public Sub PrintToXLS(strQryName As String, strTitle As String, intDataStartCol As Integer, Optional intDataStartRow = 2)

On Error GoTo err_trap
Dim xls As Excel.Application
Dim wb As Excel.Workbook
Dim myRange As Excel.Range
Dim i As Integer
Dim j As Integer
Dim intCols As Integer
Dim intRows As Integer
Dim nValue As single
Dim sFileName As String
sFileName = CurrentProject.Path & "\timesheet.xls"
If Dir$(sFileName) <> "" Then
Kill sFileName
End If
'Now run the x-tab query in Access and output to Excel 2003.
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, strQryName, sFileName
Set xls = New Excel.Application
Set wb = Workbooks.Open(sFileName)
Set myRange = ActiveSheet.UsedRange
'Get a range/count of cells that are used.
intCols = myRange.Columns.Count
intRows = myRange.Rows.Count
'Add up the cells vertically to get a sum amount.
For j = intDataStartCol To intCols
nValue = 0
For i = intDataStartRow To intRows
nValue = Cells(i, j).Value + nValue
Next 'Next cell
Cells(i, j).Value = nValue 'insert the sum now that we are done with the column.
Cells(i, j).Font.Bold = True 'bold it
Next j 'Next column
With Cells(intRows + 1, intDataStartCol - 1)
.Value = "Total"
.Font.Bold = True
.Select
.HorizontalAlignment = xlRight
End With
'Add up the totals horizontally to get a sum amount.
For i = intDataStartRow To intRows
nValue = 0
For j = intDataStartCol To intCols
nValue = Cells(i, j).Value + nValue
Next j 'Next column
Cells(i, j).Value = nValue 'insert the sum now that we are done with the column.
Cells(i, j).Font.Bold = True 'bold it
Next i 'Next row
With Cells(1, j)
.Value = "Total"
.Font.Bold = True
.Select
.HorizontalAlignment = xlRight
End With
'Resize the columns
For i = 1 To intCols
myRange.Columns(i).AutoFit
Next i
'Bold the headers/field names.
myRange.Rows(1).Font.Bold = True
'Change the font size for the column names and data.
myRange.Font.Size = 6
'Format some printing/page setup items.
With ActiveSheet.PageSetup
.LeftHeader = "&""Arial,Bold""&12" & strTitle 'This is our title.
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = Date
.CenterFooter = ""
.RightFooter = "Page &P of &N"
.PrintGridlines = True
.Orientation = xlLandscape
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
End With
'Refresh the spreadsheet since we've made changes.
wb.RefreshAll
'Print out the spreadhseet.
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
cleanup:
'Close the workbook and don't save changes.
If Not (wb Is Nothing) Then
wb.Close False
End If
If Not (wb Is Nothing) Then
Set wb = Nothing
End If
If Not (xls Is Nothing) Then
Set xls = Nothing
End If

Exit Sub
err_trap:
MsgBox Err.Number & ": " & Err.Description, vbCritical
Resume cleanup

I know you'll have to alter it in some way but take a look at it.
--Craig

 

[boblarson]

Umm, Craig -

They said they wanted to copy from a continuous form in Access by multi-selecting certain rows LIKE you can do in Excel. Not that they wanted it to GO to Excel. At least that was my reading of the post.

 

[CraigWarmy]

Umm, Craig -

They said they wanted to copy from a continuous form in Access by multi-selecting certain rows LIKE you can do in Excel. Not that they wanted it to GO to Excel. At least that was my reading of the post.

Sorry. Was just trying to help.

 

[boblarson]

Sorry. Was just trying to help.

Which is a good thing, believe me.

 

[wiklendt]

Sorry. Was just trying to help.

hi. if i could trouble you for a little more help? i have no experience in coding for external applications via VBA in access, however, i have never the lss attempted to adapt your code for my own needs. i have a working export of a query to excel via the OutputTo command:

DoCmd.OutputTo acOutputQuery, strDoc, "Excel97-Excel2003Workbook(*.xls)", strExportFile, False, "", 0, acExportQualityPrint

i then wanted to follow this code with your formatting code to arrange the file a little bit. mainly in order to:

• freeze pane (row 1)
• repeat line on print (row 1)
• landscape orientation
• footer showing (page of pages) and file path

i figured i could start attempting at least the last two, seeing as they are featured in your code. however, i am getting a compile error: user type not defined on the first line (*sigh*):

Dim xls As Excel.Application

Access help said:

If you haven't set a reference to the Microsoft Excel type library, you must declare the variable as a generic variable of type Object (Object data type: A fundamental data type representing any object that can be recognized by Visual Basic. Although you can declare any object variable as type Object, it is best to declare object variables according to their specific types

and offered this as an option:

Dim appXL As Object

but when i added

Dim xls As Excel.Application

to my code, it simply gave me the same user-type not defined compile error and highlighted the object line instead. :-/

i am using Office 2007, with excel installed.

if i rem out all the code for the excel formatting, the remaining procedure finishes as written (i.e., export with OutputTo, but only with the limited formatting this command has provision for).

here is the full procedure with both yours and my code... a lot of my changes or additions are guess work, so don't be surprised if you see more errors throughout... (and please feel free to let me know where i've gone wrong!)

Private Sub cmdExportStockList_Click()
On Error GoTo Err_cmdExportStockList_Click

    Dim strDate, strFileName As String
    Dim strExportFile, strExportPath, strExportFolder, strDoc As String
    Dim strMsgTitle, strMsgInfo, strMsgError As String
    Dim intAnswer As Integer
    
    strDoc = "qryExportStocktake"
    strDate = Format(Date, "YYYY-MM-DD")
    strFileName = "Stocktake template " & strDate & ".xls"
    
    strExportFolder = "Exports\"
    strExportPath = fHTC_GetBEFolder("tblOrders") & strExportFolder
    strExportFile = fHTC_GetBEFolder("tblOrders") & strExportFolder & strFileName
    
    strMsgTitle = "RLS Ordering Records"
    strMsgInfo = vbInformation + vbYesNo
    strMsgError = vbCritical + vbOKOnly
    
    'exports to Excel 97-2003 format, with some formatting
    '(note to self: find out how to export using a master template file OR how to format current export.)
    DoCmd.OutputTo acOutputQuery, strDoc, "Excel97-Excel2003Workbook(*.xls)", strExportFile, True, "", 0, acExportQualityPrint
    
    'format the file so that printing is improved, adapted from CraigWarmy  AWF;
    'http://www.access-programmers.co.uk/forums/showthread.php?t=177181
    '---------------------------------------------------
[COLOR="Red"]    Dim xls As Excel.Application
[/COLOR]    Dim wb As Excel.Workbook
    Dim myRange As Excel.Range
    Dim i As Integer
    Dim j As Integer
    Dim intCols As Integer
    Dim intRows As Integer
    Dim nValue As Single
    Dim intDataStartCol As Integer
    Dim intDataStartRow As Integer
    
    intDataStartRow = 2

    Set xls = New Excel.Application
    Set wb = Workbooks.Open(strExportFile)
    Set myRange = ActiveSheet.UsedRange

    'Get a range/count of cells that are used.
    intCols = myRange.Columns.Count
    intRows = myRange.Rows.Count

    'Resize the columns
    For i = 1 To intCols
        myRange.Columns(i).AutoFit
    Next i

    'Bold the headers/field names.
    myRange.Rows(1).Font.Bold = True

    'Change the font size for the column names and data.
    'myRange.Font.Size = 11

    'Format some printing/page setup items.
    With ActiveSheet.PageSetup
        .LeftHeader = "&""Calibri,Bold""&11"
        .CenterHeader = ""
        .RightHeader = Date
        .LeftFooter = """ & strExportFile & """
        .CenterFooter = ""
        .RightFooter = "Page &P of &N"
        .PrintGridlines = True
        .Orientation = xlLandscape
    End With

    'Refresh and save the spreadsheet since we've made changes.
        wb.RefreshAll
        xls.ActiveWorkbook.Save
	xls.ActiveWorkbook.Close
    
    'Print out the spreadhseet.
    'ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
    '---------------------------------------------------
    
    intAnswer = MsgBox(strFileName & " saved. " & Chr(13) & Chr(13) & "This file overwrites any previous data file made today." & Chr(13) & Chr(13) & "Path to file: " & Chr(13) & strExportFile & Chr(13) & Chr(13) & "Would you like to open the file now?", strMsgInfo, strMsgTitle)
    
    If intAnswer = vbYes Then 'open the excel file for the user
    
        ' --------------------------------------------------------------------
        ' open native application for file being opened.
        ' code from access world forums courtesy DCrake
        ' http://www.access-programmers.co.uk/forums/showthread.php?t=183107
        ' current as at 2009-11-13 (see also form declarations, above)

        Dim nDT, nApp

        nDT = GetDesktopWindow()
        nApp = ShellExecute(nDT, "Open", strExportFile, "", "C:\", SW_SHOWNORMAL)
        DoEvents
        ' --------------------------------------------------------------------
    
    Else
        Exit Sub
    End If
 
Exit_cmdExportStockList_Click:
    Exit Sub

Err_cmdExportStockList_Click:
     
    Select Case Err.Number
      Case 3044
        'destination folder does not exist, replace default warning with this:
        MsgBox "Could not write file." & Chr(13) & Chr(13) & "Please ensure the subfolder " & strExportFolder & " exists in the database directory, then try again." & Chr(13) & Chr(13) & "Full file path expected:" & Chr(13) & strExportPath, strMsgError, strMsgTitle
      Case Else
        Msg = "Error # " & Str(Err.Number) & Chr(13) & Err.Description
        MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
    End Select
   
    Resume Exit_cmdExportStockList_Click

End Sub

any suggestions appreciated

 

[wiklendt]

ok, i managed to get all my formatting into my excel export here are the codes i used:

function to create and format excel spreadsheet, saved in a standard module:

Option Compare Database

'this module adapted from Bob Larson, BTAB Development
'http://www.btabdevelopment.com/main/CodeSnippets/SendTableQuerytoExcel/tabid/144/Default.aspx

Public Function fncSendTQ2Excel(strTQName As String, FileName As String, ExportPath As String, Optional SheetName As String)
' strTQName is the name of the table or query you want to send to Excel
' FileName is the name of the file you want saved
' ExportPath is the path where the file should be saved
' SheetName is the name of the sheet you want to name it to
' usage: fncSendTQ2Excel QueryName, DesiredSheetName
' (i.e., no parentheses, no "Call" prefix)

On Error GoTo err_handler
    
    Dim rst As DAO.Recordset
    Dim ApXL As Object
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim fld As Field
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107

    Dim strMsgTitle As String
    Dim strMsgInfo As String
    Dim strMsgError As String
    
    strMsgTitle = "RLS Ordering Records"
    strMsgInfo = vbInformation + vbYesNo
    strMsgError = vbCritical + vbOKOnly

    Set rst = CurrentDb.OpenRecordset(strTQName)

    ' create an excel workbook...
    ' figure out how to save a new workbook with a specified name and path
    Set ApXL = CreateObject("Excel.Application")
    Set xlWBk = ApXL.Workbooks.Add
    
    ' ...but hide the progress
    ' (user will be prompted to open the file, if they wish, once it's completed)
    ApXL.Visible = False ' False = do in background (no excel app appears to open)
       
    ' name the sheet, if the user gave an optional sheet name
    Set xlWSh = xlWBk.Worksheets("Sheet1")
    If Len(SheetName) > 0 Then
        xlWSh.Name = Left(SheetName, 34)
    End If
    
    ' save the work book to the pre-defined file path and name
    ' [code here]
    
    ' selects the first cell
    xlWSh.Range("A1").Select
    
    ' Make Unit Price column as Currency
    ' (must be done before header text pasted)
    ' --------------------------------------
    ApXL.ActiveSheet.Range("C:C").Select
    ' applies currency format to them
    ApXL.Selection.NumberFormat = "$#,##0.00"
    ' selects the first cell to unselect all cells
    xlWSh.Range("A1").Select
    ' --------------------------------------
    
    ' copy field names to first row
    For Each fld In rst.Fields
        ApXL.ActiveCell = fld.Name
        ApXL.ActiveCell.Offset(0, 1).Select
    Next

    ' copy recordset
    rst.MoveFirst
    xlWSh.Range("A2").CopyFromRecordset rst
    
    ' FORMAT
    ' -------------------------------------------
    
    ' select first (header) row for formatting
    xlWSh.Range("1:1").Select
    
    'Formatting for header row (font)
    With ApXL.Selection.Font
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Bold = True
    End With
    
    'Formatting for header row (cells)
    With ApXL.Selection
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = False
        .Interior.Color = RGB(219, 238, 243)
    End With
    
    ' selects all of the cells
    ApXL.ActiveSheet.Cells.Select
    
    ' makes all text Calibri font of size 11 points
    With ApXL.Selection.Font
        .Name = "Calibri"
        .Size = 11
    End With
        
    ' does the "autofit" for all columns
    ApXL.ActiveSheet.Cells.EntireColumn.AutoFit
    
    ' selects the first cell to unselect all cells
    xlWSh.Range("A1").Select

    'Format some printing/page setup items.
    With ApXL.ActiveSheet.PageSetup
        .LeftHeader = "&D" ' (date)
        .CenterHeader = ""
        .RightHeader = "Page &P of &N" ' Page (page numer) of (number of pages)
        .LeftFooter = "&Z&F" '(path)(file)
        .CenterFooter = ""
        .RightFooter = ""
        .PrintGridlines = True
        .PrintTitleRows = "1:1"
        .Orientation = 2 ' 1 = portrait; 2 = landscape
    End With
    
    ' split the window at row 1, and freeze panes - for easy scrolling
    With ApXL.ActiveWindow
        .SplitRow = 1
        .FreezePanes = True
    End With
    ' -------------------------------------------
    ' -------------------------------------------
    ' End formatting code
    
    ' CLEANUP
    ' ----------------
    rst.Close
    Set rst = Nothing
    ' ----------------
        
    ' SAVE
    '-----------------------------------------------------------------
    ' save the workbook to the pre-defined file path and name
    Dim ExportFile As String
    ExportFile = ExportPath & FileName
    
    ApXL.DisplayAlerts = False ' allows file to ovewrite any with same name in full path
    xlWBk.SaveAs FileName:=ExportFile, FileFormat:=-4143  '-4143 (xlWorkbookNormal) 51 (xlWorkbookDefault)
    ApXL.DisplayAlerts = True ' turns on alerts again

    ' CLOSE
    '-----------------------------------------------------------------
    xlWBk.Close

    Exit Function
    
err_handler:
    DoCmd.SetWarnings True
    Select Case Err.Number
      Case 1004
        'destination folder does not exist, replace default warning with this:
        MsgBox "Could not write file." & Chr(13) & Chr(13) & "Please ensure the export subfolder exists in the database directory, then try again." & Chr(13) & Chr(13) & "Full file path expected:" & Chr(13) & ExportPath, strMsgError, strMsgTitle
      Case Else
        Msg = "Error # " & Str(Err.Number) & Chr(13) & Err.Description
        MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
    End Select
Exit Function

End Function

and this is the code to call the function and to open the file, if the user desires.

in the "on click" event of a button:

Private Sub cmdExportStockList_Click()
On Error GoTo Err_cmdExportStockList_Click

    Dim strDoc As String
    Dim strDate As String
    Dim strFileName As String
    Dim strSheetName As String
    
    Dim strExportPath As String
    Dim strExportFolder As String
    
    Dim intAnswer As Integer
    
    Dim strMsgTitle As String
    Dim strMsgInfo As String
    Dim strMsgError As String
    
    strMsgTitle = "RLS Ordering Records"
    strMsgInfo = vbInformation + vbYesNo
    strMsgError = vbCritical + vbOKOnly

    strDoc = "qryExportStocktake"
    strDate = Format(Date, "YYYY-MM-DD")
    strSheetName = "RLS Stocktake"
    
    strFileName = "Stocktake template " & strDate & ".xls"
    strExportFolder = "Exports\"
    strExportPath = fHTC_GetBEFolder("tblOrders") & strExportFolder
    
    DoCmd.Hourglass True
        fncSendTQ2Excel strDoc, strFileName, strExportPath, strSheetName
    DoCmd.Hourglass False

    intAnswer = MsgBox(strFileName & " saved. " & Chr(13) & Chr(13) & "This file overwrites any previous data file made today." & Chr(13) & Chr(13) & "Path to file: " & Chr(13) & strExportPath & strFileName & Chr(13) & Chr(13) & "Would you like to open the file now?", strMsgInfo, strMsgTitle)

    If intAnswer = vbYes Then 'open the excel file for the user

        ' --------------------------------------------------------------------
        ' open native application for file being opened.
        ' code from access world forums courtesy DCrake
        ' http://www.access-programmers.co.uk/forums/showthread.php?t=183107
        ' current as at 2009-11-13 (see also form declarations, above)

        Dim nDT, nApp

        nDT = GetDesktopWindow()
        nApp = ShellExecute(nDT, "Open", strExportPath & strFileName, "", "C:\", SW_SHOWNORMAL)
        DoEvents
        ' --------------------------------------------------------------------

    Else
        Exit Sub
    End If
    
Exit_cmdExportStockList_Click:
    Exit Sub

Err_cmdExportStockList_Click:
     
    Msg = "Error # " & Str(Err.Number) & Chr(13) & Err.Description
    MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
    Resume Exit_cmdExportStockList_Click

End Sub

the above button code uses another function to find the path of the BE (note it finds the location of ONE table as specified, b/c there may be many BE's for one FE) database (fHTC_GetBEFolder), in order to save the exported file on the shared network drive instead of the local directory of the FE. here is that module (all the following code saved into one standard module, separate from the excel formatting, to keep things tidy), supplied by HighTechCoach:

Option Compare Database
Option Explicit

Public Function fHTC_GetBEFolder(pTableName As String) As String
' usage example: fHTC_GetBEFolder("Suppliers")
    
    Dim strFullPath As String
    Dim i As Long
    strFullPath = Mid(DBEngine.Workspaces(0).Databases(0).TableDefs(pTableName).Connect, 11)

    For i = Len(strFullPath) To 1 Step -1
        If Mid(strFullPath, i, 1) = "\" Then
            fHTC_GetBEFolder = Left(strFullPath, i)
            Exit For
        End If
    Next

End Function

Public Function fHTC_GetBEName(pTableName As String) As String
' usage example: fHTC_GetBEName("Suppliers")

    Dim strFullPath As String
    Dim i As Long
    strFullPath = Mid(DBEngine.Workspaces(0).Databases(0).TableDefs(pTableName).Connect, 11)

    For i = Len(strFullPath) To 1 Step -1
        If Mid(strFullPath, i, 1) = "\" Then
            fHTC_GetBEName = Mid(strFullPath, i + 1)
            Exit For
        End If
    Next


End Function

Public Function fHTC_GetBEFullPath(pTableName As String) As String
' usage example: fHTC_GetBEFullPath("Suppliers")
    
    fHTC_GetBEFullPath = Mid(DBEngine.Workspaces(0).Databases(0).TableDefs(pTableName).Connect, 11)

End Function

i think that's everything. please post any questions if you get stuck