Home | Contact Us | FAQ | Search & Site Map | Link to Us
Sign In | Join | Other 45 Sites in Network
Home
Discussion GroupsFormsForms ProgrammingQueriesModules / DAO / VBAReports / PrintingMacrosDatabase DesignSecurityConversionImporting / LinkingSQL Server / ADPMultiuser / NetworkingReplicationSetup / ConfigurationDeveloper ToolkitsActiveX ControlsNew UsersGeneral 1General 2
Access DirectoryToolsTutorialsUser Groups
Related Topics
SQL ServerOther DB ProductsMS OfficeMore Topics ...

MS Access Forum / Modules / DAO / VBA / March 2005

Tip: Looking for answers? Try searching our database.

Reading from Excel into an Access form

Thread view: 
Enable EMail Alerts  Start New Thread
Thread rating: 
Enterprise Andy - 15 Mar 2005 10:43 GMT
Hi all,

I would like some suggestion about the best way to read from an Excel
spreadsheet into an Access form. The data I want to read from Excel is only
from a few specific cells, not a range of cells, and it needs to be fed into
an Access form that mirrors the 'look and feel' of the Excel form. The Access
form is already set up, I just need to method of reading the data across.

Is there anyway to reference Excel objects directly in Access, like you
would with forms e.g. Froms!Formname!Control? If there is then I can simply
assign the values directly from the referenced cells in Excel.

Many thanks in advance for your help.

Andy
JaRa - 15 Mar 2005 11:15 GMT
Hi this class can help you i think keep in mind that i use some excel
defaults from the excel object 8.0
It might be you have to replace them and don't forget to set a reference to
Excel

- Raoul

'*********************************************************************************
'This class module was contributed by Raoul Jacobs
'       via MS Access Developer's Forum 3/14/2005
'*********************************************************************************
'Raoul Jacobs
'Jacob Jordaensstraat 118
'2018 Antwerpen
'Belgium
'T. +32 (0)475 31 41 93
'E.jara@ opmaat.be
'U. http://www.opmaat.be
'*********************************************************************************
Option Compare Database
Option Explicit
Public Filename As String

Public Row As Long
Public Column As Long

Public xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Dim xlApp As Excel.Application
Public Sub CreateFile(Filename As String, Optional OpenFile As Boolean =
False, Optional Visible As Boolean = False)
   Me.Filename = Filename
   Set xlWB = xlApp.Workbooks.add
   If Not OpenFile Then
       xlWB.Close True, Me.Filename
       Set xlWB = Nothing
   Else
       xlWB.SaveAs Me.Filename
       xlApp.Visible = Visible
   End If
End Sub
Public Sub OpenFile(Optional Filename As String = "", Optional Visible As
Boolean = False)
   If Len(Filename) > 0 Then
       Me.Filename = Filename
   End If
   Set xlWB = xlApp.Workbooks.Open(Me.Filename)
   xlApp.Visible = Visible
End Sub
Public Sub CloseFile(Optional Save As Boolean = True)
   If Not IsNothing(xlWB) Then
       xlWB.Close Save
   End If
   Set xlWB = Nothing
End Sub
Public Function CreateWorksheet(WorksheetName As String) As Excel.Worksheet
   Set xlWS = xlWB.Worksheets.add
   xlWS.Name = WorksheetName
   Set CreateWorksheet = xlWS
End Function
Public Sub RemoveWorksheets()
Dim i As Integer

   Set xlWS = Nothing
   For i = xlWB.Sheets.Count To 2 Step -1
       xlWB.Sheets(i).Delete
   Next
End Sub
Public Function RenameWorkSheet(OldName As String, ByVal NewName As String,
Optional AutoNumber As Boolean = True) As Excel.Worksheet
Dim bFound As Boolean
Dim iSheetId As Integer
Dim strSheet As String
Dim xlSheet As Excel.Worksheet
Dim lPosId As Long

   strSheet = NewName
   If AutoNumber Then
       bFound = True
       iSheetId = 0
       While bFound
           bFound = False
           For Each xlSheet In xlWB.Sheets
                If xlSheet.Name = strSheet Then
                   lPosId = 0
                   If Right(strSheet, 1) = ")" Then
                       lPosId = InStrRev(strSheet, "(")
                   End If
                   If lPosId > 0 Then
                       iSheetId = Val(Mid(strSheet, lPosId + 1)) + 1
                       strSheet = Left(strSheet, lPosId) & iSheetId & ")"
                   Else
                       iSheetId = 1
                       strSheet = strSheet & "(1)"
                   End If
                   bFound = True
                End If
           Next
       Wend
       If iSheetId = 0 Then
           strSheet = NewName
       Else
           lPosId = 0
           If Right(NewName, 1) = ")" Then
               lPosId = InStrRev(NewName, "(")
           End If
           If lPosId > 0 Then
               strSheet = Left(NewName, lPosId - 1) & Chr(40) & iSheetId &
Chr(41)
           Else
               strSheet = NewName & Chr(40) & iSheetId & Chr(41)
           End If
       End If
   End If
   Me.SelectWorksheet OldName
   xlWS.Name = strSheet
   Set RenameWorkSheet = xlWS
End Function
Public Function SelectWorksheet(WorksheetName As String) As Excel.Worksheet
   Set xlWS = xlWB.Sheets(WorksheetName)
   Set SelectWorksheet = xlWS
End Function
Public Sub FormatWorksheet(Optional RowHeight As Integer = 0, Optional
ColumnWidth As Integer = 0, Optional WrapText As omBool = omBool.omNotUsed)

   xlWS.Cells.Select
   With xlWS.Application.Selection
       '.HorizontalAlignment = xlGeneral
       '.VerticalAlignment = xlBottom
       .WrapText = WrapText
       '.Orientation = 0
       '.AddIndent = False
       '.IndentLevel = 0
       '.ShrinkToFit = False
       '.ReadingOrder = xlContext
       .RowHeight = RowHeight
       .ColumnWidth = ColumnWidth
   End With
End Sub
Public Sub SetValue(Value As String, Optional RowMove As Long = 0, Optional
ColumnMove As Long = 0, Optional RowOffset As Long = 0, Optional ColumnOffset
As Long = 0, Optional Bold As Boolean = False, Optional FontSize As Integer =
0)
   Me.SelectRange RowOffset:=RowOffset, ColumnOffset:=ColumnOffset
   xlWS.Application.ActiveCell.Value = Value
   'xlWS.Cells.Value = Value
   'xlWS.Cells(Row + RowOffset, Column + ColumnOffset) = Value
   'xlWS.Cells(Row + RowOffset, Column + ColumnOffset).Select
   With xlWS.Application.Selection.Font
       .Bold = Bold
       If FontSize <> 0 Then
           .Size = FontSize
       End If
   End With
   Me.Row = Me.Row + RowMove
   Me.Column = Me.Column + ColumnMove
End Sub
Public Function GetValue(Optional RowOffset As Long = 0, Optional
ColumnOffset As Long = 0) As String
   GetValue = Nz(xlWS.Cells(Row + RowOffset, Column + ColumnOffset))
End Function
Public Sub MergeCells(Optional Rows As Long = 0, Optional Columns As Long =
0, Optional RowOffset As Long = 0, Optional ColumnOffset As Long = 0)
   If Rows <> 0 Or Columns <> 0 Then
       xlWS.Range(xlWS.Cells(Row + RowOffset, Column + ColumnOffset),
xlWS.Cells(Row + RowOffset + IIf(Rows > 0, Rows - 1, 0), Column +
ColumnOffset + IIf(Columns > 0, Columns - 1, 0))).MergeCells = True
   End If
End Sub
Public Sub FormatCells(Optional Rows As Long = 0, Optional Columns As Long =
0, Optional RowOffset As Long = 0, Optional ColumnOffset As Long = 0,
Optional SetBorder As Boolean = False, Optional BorderWeight As
XlBorderWeight = XlBorderWeight.xlThick, Optional ClearInsideLines As Boolean
= False, Optional InsideBorderWeight As XlBorderWeight =
XlBorderWeight.xlThin, Optional InsideVerticalLineStyle As XlLineStyle =
XlLineStyle.xlLineStyleNone, Optional InsideHorizontalLineStyle As
XlLineStyle = XlLineStyle.xlLineStyleNone, Optional FillBackGround As Boolean
= False, Optional FillBackGroundColor As XlColorIndex = 15, Optional
HorizontalAlignment As Excel.Constants = Excel.Constants.xlNone, Optional
VerticalAlignment As Excel.Constants = Excel.Constants.xlNone)
   Me.SelectRange Rows:=Rows, RowOffset:=RowOffset, Columns:=Columns,
ColumnOffset:=ColumnOffset
   With xlWS.Application.Selection
       If SetBorder Then
           With .Borders(xlEdgeLeft)
               .LineStyle = xlContinuous
               .Weight = BorderWeight
               .ColorIndex = xlAutomatic
           End With
           With .Borders(xlEdgeTop)
               .LineStyle = xlContinuous
               .Weight = BorderWeight
               .ColorIndex = xlAutomatic
           End With
           With .Borders(xlEdgeBottom)
               .LineStyle = xlContinuous
               .Weight = BorderWeight
               .ColorIndex = xlAutomatic
           End With
           With .Borders(xlEdgeRight)
               .LineStyle = xlContinuous
               .Weight = BorderWeight
               .ColorIndex = xlAutomatic
           End With
           If ClearInsideLines Then
               .Borders(xlInsideVertical).LineStyle = xlNone
           End If
           If InsideVerticalLineStyle <> XlLineStyle.xlLineStyleNone Then
               With .Borders(xlInsideVertical)
                   .LineStyle = InsideVerticalLineStyle
                   .Weight = InsideBorderWeight
                   .ColorIndex = xlAutomatic
               End With
           End If
           If InsideHorizontalLineStyle <> XlLineStyle.xlLineStyleNone Then
               With .Borders(xlInsideHorizontal)
                   .LineStyle = InsideHorizontalLineStyle
                   .Weight = InsideBorderWeight
                   .ColorIndex = xlAutomatic
               End With
           End If
       End If
       If FillBackGround Then
           With .Interior
               .ColorIndex = FillBackGroundColor
               .Pattern = xlSolid
           End With
       End If
       If HorizontalAlignment <> xlNone Then
           .HorizontalAlignment = HorizontalAlignment
       End If
       If VerticalAlignment <> xlNone Then
           .VerticalAlignment = VerticalAlignment
       End If
   End With
End Sub
Public Function GetLastActiveRow() As Long
   xlWS.Application.ActiveCell.SpecialCells(xlLastCell).Select
   If xlWS.Application.ActiveCell.MergeCells Then
       GetLastActiveRow = xlWS.Application.ActiveCell.Row +
xlWS.Application.ActiveCell.MergeArea.Rows.Count - 1
   Else
       GetLastActiveRow = xlWS.Application.ActiveCell.Row
   End If
End Function
Public Function GetLastActiveColumn() As Long
   xlWS.Application.ActiveCell.SpecialCells(xlLastCell).Select
   If xlWS.Application.ActiveCell.MergeCells Then
       GetLastActiveColumn = xlWS.Application.ActiveCell.Column +
xlWS.Application.ActiveCell.MergeArea.Columns.Count - 1
   Else
       GetLastActiveColumn = xlWS.Application.ActiveCell.Column
   End If
End Function
Public Sub InsertRows(Rows As Long, Optional Shift As XlDirection =
XlDirection.xlDown)
   With xlWB.Application
       .Rows(Me.Row & ":" & Me.Row + Rows - 1).Select
       .Selection.Insert Shift:=Shift
   End With
End Sub
Public Sub SelectRange(Optional Row As Long = 0, Optional Rows As Long = 0,
Optional RowOffset As Long = 0, Optional Column As Long = 0, Optional Columns
As Long = 0, Optional ColumnOffset As Long = 0)
   If Row <> 0 Then
       Me.Row = Row
   End If
   If Column <> 0 Then
       Me.Column = Column
   End If
   xlWS.Range(xlWS.Cells(Me.Row + RowOffset, Me.Column + ColumnOffset),
xlWS.Cells(Me.Row + RowOffset + IIf(Rows > 0, Rows - 1, 0), Me.Column +
ColumnOffset + IIf(Columns > 0, Columns - 1, 0))).Select
End Sub
Public Sub PageSetup(Optional Orientation As XlPageOrientation =
XlPageOrientation.xlPortrait, Optional Order As XlOrder =
XlOrder.xlOverThenDown, Optional LeftMargin As Double = 1, Optional
RightMargin As Double = 1, Optional TopMargin As Double = 1, Optional
BottomMargin As Double = 1, Optional HeaderMargin As Double = 0.5, Optional
FooterMargin As Double = 0.5, Optional Zoom As Double = False, Optional
PrintTitleRows As String = "", Optional PrintTitleColumns As String = "")
   With xlWB.ActiveSheet.PageSetup
       .PrintTitleRows = PrintTitleRows
       .PrintTitleColumns = PrintTitleColumns
   End With
   'xlWB.ActiveSheet.PageSetup.PrintArea = ""
   With xlWB.ActiveSheet.PageSetup
       .Orientation = Orientation
       .PaperSize = xlPaperA4
       .Order = Order
       .LeftMargin = xlWB.Application.CentimetersToPoints(LeftMargin)
       .RightMargin = xlWB.Application.CentimetersToPoints(RightMargin)
       .TopMargin = xlWB.Application.CentimetersToPoints(TopMargin)
       .BottomMargin = xlWB.Application.CentimetersToPoints(BottomMargin)
       .HeaderMargin = xlWB.Application.CentimetersToPoints(HeaderMargin)
       .FooterMargin = xlWB.Application.CentimetersToPoints(FooterMargin)
       .Zoom = Zoom
       
       
       '.LeftHeader = ""
       '.CenterHeader = ""
       '.RightHeader = ""
       '.LeftFooter = ""
       '.CenterFooter = ""
       '.RightFooter = ""
       '.PrintHeadings = False
       '.PrintGridlines = False
       '.PrintComments = xlPrintNoComments
       '.PrintQuality = -3
       '.CenterHorizontally = False
       '.CenterVertically = False
       
       '.Draft = False
       '.FirstPageNumber = xlAutomatic
       '.BlackAndWhite = False
       '.FitToPagesWide = 4
       '.FitToPagesTall = 1
       '.PrintErrors = xlPrintErrorsDisplayed
   End With
End Sub
Public Sub FormatSelection(Optional HorizontalAlignment As Excel.Constants =
Excel.Constants.xlNone, Optional VerticalAlignment As Excel.Constants =
Excel.Constants.xlNone, Optional WrapText As omBool = omBool.omNotUsed,
Optional Orientation As Integer = 0, Optional AddIndent As omBool =
omBool.omNotUsed, Optional IndentLevel As Integer = 0, Optional ShrinkToFit
As omBool = omBool.omNotUsed, Optional ReadingOrder As XlReadingOrder =
XlReadingOrder.xlContext, Optional MergeCells As omBool = omBool.omNotUsed,
Optional RowHeight As Integer = 0, Optional ColumnWidth As Integer = 0)
   With xlWS.Application.Selection
       If HorizontalAlignment <> xlNone Then
           .HorizontalAlignment = HorizontalAlignment
       End If
       If VerticalAlignment <> xlNone Then
           .VerticalAlignment = VerticalAlignment
       End If
       If WrapText <> omNotUsed Then
           .WrapText = WrapText
       End If
       .Orientation = Orientation
       If AddIndent <> omNotUsed Then
           .AddIndent = AddIndent
           .IndentLevel = IndentLevel
       End If
       If ShrinkToFit <> omNotUsed Then
           .ShrinkToFit = ShrinkToFit
       End If
       .ReadingOrder = ReadingOrder
       If MergeCells <> omNotUsed Then
           .MergeCells = MergeCells
       End If
       If RowHeight <> 0 Then
           .RowHeight = RowHeight
       End If
       If ColumnWidth <> 0 Then
           .ColumnWidth = ColumnWidth
       End If
   End With
End Sub
Public Sub RemoveEqualValues(Optional Row As Long = 0, Optional Column As
Long = 0, Optional Direction As Excel.XlDirection = XlDirection.xlDown,
Optional InsertAbove As Boolean = True)
Dim strTemp As String
Dim i As Long
Dim LastActiveColumn As Long
Dim LastActiveRow As Long

   If Row > 0 Then
       Me.Row = Row
   End If
   If Column > 0 Then
       Me.Column = Column
   End If
   strTemp = xlWS.Cells(Me.Row, Me.Column)
   If Direction = xlDown Then
       i = Me.Row + 1
       LastActiveRow = Me.GetLastActiveRow
       While i <= LastActiveRow
           If xlWS.Cells(i, Me.Column) <> "" Then
               If strTemp = xlWS.Cells(i, Me.Column) Then
                   xlWS.Cells(i, Me.Column) = ""
               Else
                   strTemp = xlWS.Cells(i, Me.Column)
                   If InsertAbove Then
                       xlWS.Rows(i & ":" & i).Select
                       xlWS.Application.Selection.Insert Shift:=xlDown
                       xlWS.Application.Selection.Interior.ColorIndex =
xlNone
                       i = i + 1
                       LastActiveRow = LastActiveRow + 1
                   End If
               End If
           End If
           i = i + 1
       Wend
   ElseIf Direction = xlToRight Then
       i = Me.Column + 1
       LastActiveColumn = Me.GetLastActiveColumn
       While i <= LastActiveColumn
           If xlWS.Cells(Me.Row, i) <> "" Then
               If strTemp = xlWS.Cells(Me.Row, i) Then
                   xlWS.Cells(Me.Row, i) = ""
               Else
                   strTemp = xlWS.Cells(Me.Row, i)
               End If
           End If
           i = i + 1
       Wend
   End If
End Sub
Public Sub MoveActiveSheetToEnd()
   xlWS.Move
After:=xlWS.Application.ActiveWorkbook.Sheets(xlWS.Application.ActiveWorkbook.Sheets.Count)
End Sub

Public Sub RemoveEmptySheets()
Dim i As Long

   For i = xlWB.Sheets.Count To 1 Step -1
       If xlWB.Sheets(i).UsedRange.Rows.Count = 1 And
xlWB.Sheets(i).UsedRange.Columns.Count = 1 And xlWB.Sheets(i).Cells(1, 1) =
"" Then
           xlWB.Sheets(i).Delete
       End If
   Next i
End Sub
Private Sub Class_Initialize()
   Set xlApp = New Excel.Application
   xlApp.Application.DisplayAlerts = False
End Sub
Private Sub Class_Terminate()
   If Not IsNothing(xlWB) Then
       xlWB.Close False
   End If
   If Not IsNothing(xlApp) Then
       xlApp.Quit
   End If
   xlApp.Application.DisplayAlerts = True
   Set xlApp = Nothing
   Set xlWB = Nothing
   Set xlWS = Nothing
End Sub

> Hi all,
>
[quoted text clipped - 11 lines]
>
> Andy
 
Sign In
Join
My Latest Posts
My Monitored Threads
My Blog
My Photo Gallery
My Profile
My Homepage

Start New Thread
Enable EMail Alerts
Rate this Thread



©2008 Advenet LLC   Privacy Policy - Terms of Use
This website includes both content owned or controlled by Advenet as well as content owned or controlled by third parties.