Writing Excel cells within Access

B

Bob Bonta

Hey folks - I'm looking for a sample code snippet on
writing to an Excel spreadsheet one cell at a time from a
query built within MS Access.

Any assistance is greatly appreciated.

Thanx!

Bob
 
B

Bob Bonta

Thank you Chris. What you suggested is exactly my
intention (perhaps I wasn't clear enough in my original
post.).

Do you have a sample of how to write to Excel cells from
within Access?

Bob
 
G

Guest

Hi,

I wrote an excel wrapper class (see below) maybe this can bring you to some
ideas :
So you should copy this code into a new class object
instantiate it with e.g. dim xl as new YourClass and then you can call all
these methods and properties.

It's not a 100% but it can help some of you.

-Raoul

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
 
M

Marshall Barton

Chris2 wrote:
[]
A Query (QueryDef) in MS Access cannot send information to MS Excel.
Click to expand...
[]


No help to the OP, Chris, but you can use a query to write a
block of data to an Excel sheet or named range. Using a
tabledef that's linked the Excel file is obviously the easy
way to use an append or update query.

Another way without having a tabledef is to just use a
connect string:

INSERT INTO range IN "" "connect"
or
INSERT INTO [connect].range

OTOH, if you want to assign values to individual cells
within a sheet or named range, it is possible to open a
recordset on a query with a connect string and use .Move to
address individual rows.

Personally, I suspect that automation may be easier, but
there are times when automation is overkill for a updating a
small set of values.
 
C

Chris2

Bob Bonta said:
Hey folks - I'm looking for a sample code snippet on
writing to an Excel spreadsheet one cell at a time from a
query built within MS Access.

Any assistance is greatly appreciated.

Thanx!

Bob
Click to expand...

Bob,

A Query (QueryDef) in MS Access cannot send information to MS Excel.

You will need to write VBA code, instantiate a recordset (you can name
an existing QueryDef when you do this), and then loop through the
recordset, writing out to the MS Excel "cells" based on whatever
conditions are appropriate.


Sincerely,

Chris O.
 
B

Bob Bonta

JaRa,

Thanx for the class. I copy/pasted it all into a class
module within my access database. There were carriage
return breaks I had to correct to satisfy those syntax
errors resulting from the copy/paste.

However, when I attempted to compile the module, I got a
compile error "Variable not defined" on omBool.

For example ...
Public Sub FormatWorksheet(Optional RowHeight As Integer
= , Optional ColumnWidth As Integer = 0, Optional WrapText
As omBool = omBool.omNotUsed)

It didn't like the omBool in omBool.omNotUsed.

Suggestions?

Bob
 
G

Guest

Sorry simple enum, don't forget to set the references.

Public Enum omBool
omTrue = -1
omFalse = 0
omNotUsed = 1
End Enum

- Raoul
 
B

Bob Bonta

Thanx! I copy/pasted that and attempted to compile again
with the following error:

Variable not defined ... XlReadingOrder ... in the
following declaration:

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)

It didn't like "XlReadingOrder" in
Optional ReadingOrder As XlReadingOrder =
XlReadingOrder.xlContext

I didn't forget the references but thanx for the
reminder. The reference selected is:
Microsoft Excel 9.0 Object Library.

v/r

Bob ...

P.S.
Perhaps we could continue this off-line via email rather
than these posts - just a thought.
 
K

Ken Snell [MVP]

Some sample code that may get you started (you can add loops to this code to
loop through each worksheet in a book if you'd like). This code opens an
EXCEL workbook and reads data from it and writes the data into a recordset.
You can modify this as needed to do things directly on the spreadsheet, etc.


Dim lngColumn As Long
Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Set xlx = CreateObject("Excel.Application")
xlx.Visible = True
Set xlw = xlx.Workbooks.Open("C:\Filename.xls"), , True
Set xls = xlw.Worksheets("WorksheetName")
Set xlc = xls.Range("A1")
Set dbs = CurrentDb()
Set rst = dbs.OpenRecordset("TableName", dbOpenDynaset, dbAppendOnly)
Do While xlc.Value <> ""
rst.AddNew
For lngColumn = 0 To rst.Fields.Count - 1
rst.Fields(lngColumn).Value = xlc.Offset(0, lngColumn).Value
Next lngColumn
rst.Update
Set xlc = xlc.Offset(1,0)
Loop
rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
Set xlc = Nothing
Set xls = Nothing
xlw.Close False
Set xlw = Nothing
xlx.Quit
Set xlx = Nothing
 
G

Guest

Hi basically these are defaults which are I use to decide whether the format
should be changed yes or no.
Now most probably the excel 9.0 (i used excel.10) object didn’t support
these so you will have to amend the defaults to make it work.

- Raoul
 
G

Guest

Hey Folks! What JaRa provided to me works great. I had
to clean up the syntax from the copy/paste - here's the
final product that works within Access2K with "Microsoft
Excel 9.0 Object Library" reference selected:

Option Compare Database
Option Explicit

'**********************************************************
***********************
'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
'**********************************************************
***********************
'Code modified and customized 3/14/2005 for local use by:
'Robert s.Bonta
'Database Developer, JTIRA Lead
'Scientific Research Corporation
'OSD/JMACA
'7025 Harbour View Blvd, Ste 105
'Suffolk, VA 23435
'(e-mail address removed)
'757-638-6044 (voice)
'757-638-6170 (facsimile)
'**********************************************************
***********************

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 Enum omBool
omTrue = -1
omFalse = 0
omNotUsed = 1
End Enum

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 (xlWB Is Nothing) 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
Integer = 0, _
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 (xlWB Is Nothing) Then
xlWB.Close False
End If
If Not (xlApp Is Nothing) Then
xlApp.Quit
End If
xlApp.Application.DisplayAlerts = True
Set xlApp = Nothing
Set xlWB = Nothing
Set xlWS = Nothing
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

The data in a linked Excel spreadsheet column is truncated to 255 characters in an Access database 0
Access #Error & Excel Pivot 0
Writing to Excel header w/A2000 VBA 4
Can Access create Excel VBA 3
Creating an Excel spreadsheet via Access VBA 1
How to export table from outlook into ms access table? 0
Email Excel file from Access 3
Inserting values into individual Excel cells 2

Top