Hi,
Maybe you can try the function from this class (lower)
So just Create as class module and copy paste this code into it.
Also 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
' code based on excel object 8.0
'*********************************************************************************
'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
