Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations gkittelson on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Adding Border to resuts send to excel

Status
Not open for further replies.
jaabaar

jaabaar

Programmer
Jun 1, 2011
65
GB
Hi

The following function takes table and sends to excel.

What I need to do is carry put border outside and inside for all output result.

Can you please help me append code to do that.

Thank you for your help


Function SendToExcelDataChecks(strTableUsing As String, strTitle As String)
On Error GoTo SendToExcel_Fail

Dim objWS As Excel.Worksheet
Dim rstData As ADODB.Recordset
Dim rstCount As ADODB.Recordset
Dim fld As ADODB.Field
Dim intColCount As Integer
Dim intRowCount As Integer

Set rstData = New ADODB.Recordset
rstData.ActiveConnection = CurrentProject.Connection
Set rstCount = New ADODB.Recordset
rstCount.ActiveConnection = CurrentProject.Connection

'Invoke HourGlass
DoCmd.Hourglass True

'Try to create recordset and create Excel Object
If CreateRecordSet(rstData, rstCount, strTableUsing) Then

If CreateExcelObj() Then
'add a workbooks
With gobjExcel
'With gobjExcel
'Create a reference to the active sheet

With gobjExcel.Sheets(1)
gobjExcel.Sheets(1).Cells.ClearContents
intRowCount = 1
intColCount = 1

'Loop through the fields collection
'make each field name a collumn heading in excel
For Each fld In rstData.Fields
If fld.Type <> adLongVarBinary Then
.Cells(1, intColCount).Value = fld.Name
intColCount = intColCount + 1
End If
Next fld

.Range("A2").CopyFromRecordset rstData, 16383

.Range("A1").CurrentRegion.Copy
End With

'hide all three sheets
'gobjExcel.Sheets(1).Visible = True
'gobjExcel.Sheets(2).Visible = False
'gobjExcel.Sheets(3).Visible = False

'add a sheet in that LAST tab position
With .Worksheets.Add(After:=.Sheets(.Worksheets.Count))
.Range("B5").PasteSpecial Paste:=xlPasteAll, Transpose:=False
'.Name = strSheetName
.[c2].Value = strTitle
.[c2].EntireRow.Font.Bold = True
.[c2].EntireRow.Font.Size = 10
.[c2].EntireRow.Font.Name = "Arial"
.[c2].HorizontalAlignment = xlCenter


.Cells.EntireColumn.ColumnWidth = 30
.[B5].EntireRow.Font.Bold = True
.[B5].EntireRow.HorizontalAlignment = xlCenter
.Cells.EntireRow.Font.Size = 10
.Cells.EntireRow.Font.Name = "Arial"
.Cells.EntireRow.HorizontalAlignment = xlCenter



'autofit the columns
.Cells.EntireColumn.AutoFit

'gobjExcel.Sheets(1).Visible = False
End With
End With
Else
MsgBox "Excel not Successfully Launched", vbInformation
End If
End If

Exit_SendToExcel:
DoCmd.Hourglass False
Set objWS = Nothing
Set rstCount = Nothing
Set rstData = Nothing
Set fld = Nothing
Set gobjExcel = Nothing


Exit Function

SendToExcel_Fail:

MsgBox "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
Resume Exit_SendToExcel


End Function
 
Sort by date Sort by votes
I'd use the excel macro recorder when putting manually the borders and then adapt the produced code in my function.

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886
 
Upvote 0 Downvote
Hi

It need to be automatic as table is placed in an excell sheet. It needs to be coded part of the code above and no macro action.



Many thanks for all your help
 
Upvote 0 Downvote
thanks dhookom and ph, much appreciated!

I need it to be coded not macro for creating borders inside and outside as I need to send any table to excel. The code above may need modification. do I need to send to a seperate function?

I really would appriciate any advice or help in modifiying code to allow this action.
 
Upvote 0 Downvote
Once you use the macro recorder in Excel, you can cut the code from Excel and paste it into "the code above". You can then modify the code in Access to make sure it works as expected.

Duane
Hook'D on Access
MS Access MVP
 
Upvote 0 Downvote
Hi

I have done the following macro. I have tried to add it to above code it just will not work. I need it to take what ever table is send and create the border :( I feel so stuck. Your help would be very much appriciated.



Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
 
Upvote 0 Downvote
What was selected when you recorded this macro ?

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886
 
Upvote 0 Downvote
What I have placed there. it involes my interaction. :(
 
Upvote 0 Downvote
You should be able to use code like:
Code: 
        With gobjExcel.Sheets(1).UsedRange
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).LineStyle = xlContinuous
            .Borders(xlInsideVertical).LineStyle = xlContinuous
        End With

Duane
Hook'D on Access
MS Access MVP
 
Upvote 0 Downvote
Hi dhookom,

Thanks a lot very helpfull border works nicely much appriciated.
The other problem I have is specifiy merged cells in the new sheet(last sheet) merging cells I have tried the following but it fails:

.[B2:E2].Select
.Orientation = 0
.ShrinkToFit = False
.MergeCells = True

Updated code as folow:

Function SendToExcelCustomLayout(strTableUsing As String, strTitle As String)
On Error GoTo SendToExcelCustomLayout_Fail

Dim rstCount As ADODB.Recordset
Dim fld As ADODB.Field
Dim intColCount As Integer
Dim intRowCount As Integer

Set rstData = New ADODB.Recordset
rstData.ActiveConnection = CurrentProject.Connection
Set rstCount = New ADODB.Recordset
rstCount.ActiveConnection = CurrentProject.Connection

'Invoke HourGlass
DoCmd.Hourglass True

'Try to create recordset and create Excel Object
If CreateRecordSet(rstData, rstCount, strTableUsing) Then

If CreateExcelObj() Then
'add a workbooks
With gobjExcel
'With gobjExcel
'Create a reference to the active sheet

With gobjExcel.Sheets(1)
gobjExcel.Sheets(1).Cells.ClearContents
intRowCount = 1
intColCount = 1

'Loop through the fields collection
'make each field name a collumn heading in excel
For Each fld In rstData.Fields
If fld.Type <> adLongVarBinary Then
If fld.Name = "First name" Then
.Cells(2, 5).Value = "Request #:"
.Cells(2, 6).Value = fld.Value
ElseIf fld.Name = " Name" Then
.Cells(3, 5).Value = "Address:"
.Cells(3, 6).Value = fld.Value
ElseIf fld.Name = "Postcode" Then
.Cells(3, 7).Value = "Post Code:"
.Cells(3, 8).Value = fld.Value
End If
intColCount = intColCount + 1
End If
Next fld

.Range("E3:H48").CurrentRegion.Copy
End With

'add a sheet in that LAST tab position
With .Worksheets.Add(after:=.Sheets(.Worksheets.Count))
.Range("B3:H48").PasteSpecial Paste:=xlPasteAll, Transpose:=False
.[C2].Value = strTitle

.[C2].EntireRow.Font.Bold = True
.[C2].EntireRow.Font.Size = 10
.[C2].EntireRow.Font.Name = "Arial"
.[C2].HorizontalAlignment = xlCenter

'stretch all the cells to 30 - this maks the auto work better
'.Cells.EntireColumn.ColumnWidth = 30 'This is for everything if we use cells
.Cells.EntireColumn.ColumnWidth = 30
.[B5].EntireRow.Font.Bold = False
.[B5].EntireRow.HorizontalAlignment = xlLeft
.Cells.EntireRow.Font.Size = 10
.Cells.EntireRow.Font.Name = "Arial"
.Cells.EntireRow.HorizontalAlignment = xlCenter
.Cells.EntireRow.VerticalAlignment = -4108

.[B2:E2].Select
'.Orientation = 0
'.ShrinkToFit = False
.MergeCells = True

With gobjExcel.Sheets(.Name).UsedRange



.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous

End With


'autofit the columns
.Cells.EntireColumn.AutoFit

'gobjExcel.Sheets(1).Visible = False
End With
End With
Else
MsgBox "Excel not Successfully Launched", vbInformation
End If
End If


Exit_SendToExcelCustomLayout:
DoCmd.Hourglass False
Set objWS = Nothing
Set rstCount = Nothing
Set rstData = Nothing
Set fld = Nothing


Exit Function

SendToExcelCustomLayout_Fail:

MsgBox "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
Resume Exit_SendToExcelCustomLayout


End Function
 
Upvote 0 Downvote
HI it even fails in side the following section, as it need to be done after the border creation.

With gobjExcel.Sheets(.Name).UsedRange

.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous

End With
 
Upvote 0 Downvote
Dear All

I have fixed it thanks for much for all your help. I just needed to explicitly specify the range for merging (.[D23:E36].MergeCells = True)

Really without your help and advice somethings would have taken longer to get right.
 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

Viswa.R
  • Locked
  • Question
Dimension import from Autocad to Excel
Replies
0
Views
329
Viswa.R
Viswa.R
FrankMars
  • Locked
  • Question
Exporting Records to Excel 1
Replies
6
Views
462
Andrzejek
Andrzejek
Moss100
  • Locked
  • Question
Access send email attachments - problem when null or empty
Replies
7
Views
2K
Andrzejek
Andrzejek
Moss100
  • Locked
  • Question
Vba adding record to table when field is integer
Replies
8
Views
357
Moss100
Moss100
Zyborg
  • Locked
  • Question
Using a variable as reference to a form
Replies
5
Views
323
Zyborg
Zyborg

Part and Inventory Search

Sponsor

Back
Top