Export Access Query to Excel with Formatting - ms-access

So I have a query in access that I want to send back to excel. While using the export wizard is fine and dandy I want to add more automation to the exporting process. So far I am working on code so during the export the final excel sheet will have some formatting. As far as basic formatting I am fine, I found many resources to help me with this.
My problem is that I want to set up conditional formatting so that if a specific column(G) has a value, then the whole row is highlighted. I am a bit lost on how to set up conditional formatting for Excel through vba code in Access
Here is what I have
Dim appExcel As Variant
Dim MyStr As String
Dim rng As Excel.Range
' Creates Excel object and Adds a Workbook to it
Set appExcel = CreateObject("Excel.application")
appExcel.Visible = False
appExcel.Workbooks.Add
Set wksNew = appExcel.Worksheets("Sheet1")
appExcel.Visible = True
' The first thing I do to the worksheet is to set the font.
' Not all are required, but I included them as examples.
With appExcel
.Cells.Font.Name = "Calbri"
.Cells.Font.Size = 11
.Cells.NumberFormat = "#" 'all set to Text Fields
' My first row will contain column names, so I want to freeze it
.Rows("2:2").Select
.ActiveWindow.FreezePanes = True
' ... and I want the header row to be bold
.Rows("1:1").Font.Bold = True
.Rows("1:1").Font.ColorIndex = 1
.Rows("1:1").Interior.ColorIndex = 15
' Adds conditional formatting based on Values in the G column
rng = .Range("A2:J20").Select
rng.FormatConditions.Add Type:=xlExpression, Formula1:="=NOT($G2 = 0)"
rng.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With appExcel.Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
End With
Currently the code executes until my conditional formatting block and then it tells me that the Object Variable or With block is not set.

I checked that the following code runs until the end:
Dim appExcel As Variant
Dim MyStr As String
Dim rng As Excel.Range
Dim wksNew
' Creates Excel object and Adds a Workbook to it
Set appExcel = CreateObject("Excel.application")
appExcel.Visible = False
appExcel.Workbooks.Add
' Set wksNew = appExcel.Worksheets("Sheet1")
Set wksNew = appExcel.Worksheets(1)
appExcel.Visible = True
' The first thing I do to the worksheet is to set the font.
' Not all are required, but I included them as examples.
With appExcel
.Cells.Font.Name = "Calbri"
.Cells.Font.Size = 11
.Cells.NumberFormat = "#" 'all set to Text Fields
' My first row will contain column names, so I want to freeze it
.Rows("2:2").Select
.ActiveWindow.FreezePanes = True
' ... and I want the header row to be bold
.Rows("1:1").Font.Bold = True
.Rows("1:1").Font.ColorIndex = 1
.Rows("1:1").Interior.ColorIndex = 15
' Adds conditional formatting based on Values in the G column
Set rng = .Range("A2:J20")
rng.Select
rng.FormatConditions.Add Type:=xlExpression, Formula1:="=NOT($G2 = 0)"
rng.FormatConditions(rng.FormatConditions.Count).SetFirstPriority
With rng.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
End With
Good luck.

Related

Parsing Html in VBA using a query get request

I am using someone else's code because this is an old file other people are using, I want to update it to make it more efficient but I need a little help. Below is the vba operation. What I need is it to get the information but delete everything but a certain word which changes every time the operation is run. I could use regex and objRE.Pattern = "|" but the word changes depending on the status.
HTML:
<span onmouseover="ShowText('Message','blahblah'); return true;"
onmouseout="HideText('Message'); return true;"
href="javascript:ShowText('Message')">---(PSA)---</span>
</font><a href='?srn=numbers12131131'target='_self'><font color='#6666FF'
size='3'>numbers123232343</font></a><font size='3'>----Installed----MUM
Indication:In Scope-<font color='#00CC00'>PASS WITH WARNING</font>--- (20181018)
</td><tr></table> </b><br>
<table class="OrderForm" width="1000"> '
I just want the Installed status in my excel sheet.
VBA code that needs work:
Sub GetComment()
Dim book As Workbook
Dim sheet As Worksheet
Dim row As Integer
Dim SRN As String
Dim whttp As Object
Set book = ThisWorkbook
Set sheet = book.Worksheets("CMT Data")
Set whttp = CreateObject("WinHTTP.WinHTTPrequest.5.1")
row = 2
SRN = sheet.Cells(row, 1)
Do While SRN <> ""
Debug.Print SRN
whttp.Open "GET", "www.websitedatgoeshere.com" & SRN, False
whttp.SetRequestHeader "Cookie", "mycookiefromwebsite;"
whttp.send
Debug.Print whttp.responseText
sheet.Cells(row, 2) = whttp.responseText
row = row + 1
SRN = sheet.Cells(row, 1)
Loop
Set whttp = Nothing
End Sub
This is based on if, and only if, the word is always between "----" and "----", and that it is the first occurrence in the response. If not the first you can adjust the index 1 as required.
Debug.Print Split(Split(whttp.responseText, "----")(1), "----")(0)
sheet.Cells(row, 2) = Split(Split(whttp.responseText, "----")(1), "----")(0)

2010 Access - setting Excel hyperlink in a shape starts another Excel task

I have a 2010 Access vba procedure that creates a workbook and adds sheets. I then create a sheet (sheet1) that is a "menu" for the user the use for hyperlinking to the appropriate sheet. The code looks like this:
with ws
iLeft = 350
iTop = 140
iWidth = 160
iHeight = 30
.Shapes.AddShape(msoShapeRoundedRectangle, iLeft, iTop, iWidth, iHeight).Select
i = wks.Shapes.Count
.Shapes.Range(i).ShapeStyle = msoShapeStylePreset33
.Shapes.Range(i).TextFrame2.VerticalAnchor = msoAnchorMiddle
.Shapes.Range(i).TextFrame2.TextRange.Characters.Text = "All Data"
.Shapes.Range(i).TextFrame2.TextRange.Characters.Font.Bold = msoTrue
.Shapes.Range(i).TextFrame2.TextRange.Characters(1, 8). _
ParagraphFormat.Alignment = msoAlignCenter
With .Shapes.Range(i).TextFrame2.TextRange.Characters(1, 8).Font
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 11
.Name = "+mn-lt"
End With
Set HyperLinkShape = wks.Shapes(i)
HyperSubAddress = "'All Data'!A1"
.Hyperlinks.Add Anchor:=HyperLinkShape, Address:="", SubAddress:=HyperSubAddress
end with
There are hundreds of other lines of code, but I have narrowed down that the
.Hyperlinks.Add...
statement is causing a second occurrence of Excel to start. Normally, that happens because I should be referencing the worksheet somewhere in the statement. I tried:
.Hyperlinks.Add Anchor:=ws.HyperLinkShape, Address:="", SubAddress:=HyperSubAddress
and
.Hyperlinks.Add Anchor:=HyperLinkShape, Address:="", SubAddress:=ws.HyperSubAddress
but both of these gave me a compiler error.
Any suggestions on how I can fix this issue?
I cannot reproduce this.
The following standalone procedure runs in Access 2010. Both hyperlinks work.
After disposing of all objects (and oExcel.Quit), there is no more Excel process.
Note: you can do without all the Set obj = Nothing, then the Excel process closes after the procedure is finished, when all local variables go out of scope.
Public Sub TestExcelShapeHyperlink()
Dim oExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim shp As Excel.Shape
Set oExcel = CreateObject("Excel.Application")
With oExcel
.UserControl = True
.Visible = True
End With
Set wkb = oExcel.Workbooks.Add
Set wks = wkb.ActiveSheet
' Note: there is no reason to select the shape
Set shp = wks.Shapes.AddShape(msoShapeRoundedRectangle, 10, 10, 200, 100)
' Use the created object to set its properties
With shp
.ShapeStyle = msoShapeStylePreset10
.TextFrame2.TextRange.Font.Bold = msoTrue
.TextFrame2.VerticalAnchor = msoAnchorMiddle
.TextFrame2.TextRange.Characters.Text = "TEST TEST TEST"
.TextFrame2.TextRange.Characters.ParagraphFormat.Alignment = msoAlignCenter
.TextFrame2.TextRange.Characters.Font.Bold = msoTrue
End With
' Name 2nd sheet for hyperlink target
wkb.Worksheets(2).Name = "All Data"
' Hyperlink 1 with anchor = shape
wks.Hyperlinks.Add Anchor:=shp, Address:="", SubAddress:="'All Data'!A1"
' Hyperlink 2 with anchor = a random cell
wks.Hyperlinks.Add Anchor:=wks.Range("B11"), Address:="", SubAddress:="'All Data'!D5", TextToDisplay:="Click me, I'm a link!"
Stop ' 1 Excel process
Set shp = Nothing
Set wks = Nothing
wkb.SaveAs "D:\foo.xlsx"
wkb.Close
Set wkb = Nothing
oExcel.Quit
Set oExcel = Nothing
Stop ' 0 Excel processes
End Sub

Excel Error-The number in this cell is formatted as text or preceded by an Apostrophe

This function will export and format data to excel. However, the spreadsheet output has some data error in green as described above- So I place inside the function a code to clear this up and this does not work. Thanks for your help.
Function frmatEx()
Dim FileName As String
FileName = "C:\FolderName"
'Set xl = New Excel.Application
Set xl = CreateObject("Excel.Application")
Set wb = xl.Workbooks.Open(FileName)
With wb.Sheets(1)
.Columns("E:E").NumberFormat = "m/d/yyyy"
.Columns("A:DA").HorizontalAlignment = xlCenter
.Rows("BE:BE").ErrorCheckingOptions.NumberAsText = False
.Rows("1:1").Columns.AutoFit
End With
wb.Save
wb.Close True
Set wb = Nothing
xl.Quit
Set xl = Nothing
End Function
I will make a guess that this line is the problem:
.Rows("BE:BE").ErrorCheckingOptions.NumberAsText = False
The ErrorCheckingOptions.NumberAsText Property is not a property of a range, but a global Excel option.
So you'd have to do
xl.ErrorCheckingOptions.NumberAsText = False
but of course that will apply to all Excel files from then on.
Perhaps in a new question show how/what you are exporting, so the root problem can be solved.

xlLastCell only works half of the time

I am trying to remove the duplicates in excel via the following code:
Set rng = Range("A1", Range("A1").SpecialCells(xlLastCell))
rng.removeduplicates Columns:=8, Header:=xlYes
This method seems to work half of the time. Sometimes it works, sometimes it gives me the following error:
Searching on run-time error 1004 gives me the info that there shouldn't be strings, with more than 911 chars, which is not the case. When running the code multiple times on the same excel file, it goes well around 50 percent of the time.
I am running the code in ms access 2007, but all my references are switched on. The question is ofcourse, how to solve this, but any other, better way to easily remove my duplicates will be appreciated as well. Thank you.
EDIT: Full code:
Const xlLastCell As Long = 11
Const xlYes As Long = 1
Public Function formatreports(FileName As String) As String
Dim xl As Excel.Application
Dim xlwb As Excel.Workbook
Dim xlsh As Excel.Worksheet
Dim rng As Range
Dim newname As String
Set xl = CreateObject("Excel.Application")
xl.DisplayAlerts = False
xl.Visible = False
Set xlwb = xl.Workbooks.Open(FileName)
Set xlsh = xlwb.Worksheets(1)
'its MFR0004; This is solely for import reasons
xlsh.Rows("1:4").Delete
xlsh.Rows("2").Delete
xlsh.Columns("A:B").Delete
xlsh.Columns("B").Delete
'This as well
xlsh.Range("J1") = "Total Weight"
xlsh.Range("L1") = "Net Weight"
xlsh.Range("O1") = "Gross Weight"
xlsh.Range("AA1") = "Delivery Date"
Set rng = xlsh.Range("A1", Range("A1").SpecialCells(xlLastCell))
rng.removeduplicates Columns:=8, Header:=xlYes
newname = Left(FileName, Len(FileName) - 4) & ".XLSX"
xlwb.SaveAs newname, FileFormat:=51
formatreports = newname
xlwb.Save
xlwb.Close
xl.Quit
Set xl = Nothing
End Function
The problem is that your cells are not fully qualified.
You need to try something like this
' change sheet1 to the relevant worksheet
With ThisWorkbook.Sheets("Sheet1")
Set rng = .Range("A1", .Range("A1").SpecialCells(xlLastCell))
rng.RemoveDuplicates Columns:=8, Header:=xlYes
End With
On A side note: Since you are saying that you are working from Access and this code works sometime that means you are maybe using Early Binding. If you are not then you will have to add these to the top of your code
Const xlLastCell As Long = 11
Const xlYes As Long = 1

How to change color for part of the text in a particular field in Access?

In Access, I have a table which contain a field like this:
Part Number
A/B/C
A/B/R
T/Y/V
D/A/I
I want to change the color of the all the third part to red. So in this case C,R,V,I will be colored red. But I can't do change the color of part of the text field in Access 2007. If I use Font Change under Home tab it change the Font of entire Table. I'm so disappointed about Microsoft. Is there any way to change the color would be great :D You can recommend VBA , Macro in Form, Query, Report ...
P/S: I use Access 2007
if you can use an Access report, you can add a TextBox to the report. In the textbox, you can have a formula like this:
="<font color=""blue"">" & [ColumnA] & "</font> <u>" & [ColumnB] & "</u>"
See Access Rich-Text: Which subset of HTML is supported? for more details.
ok I think the only way is to export automatically to Excel. Finally I can do this
Private Sub CommandExport_Click()
Dim db As Database
Dim rec1 As Recordset
Dim xlFile As Object
Dim xlWorkBook As Object
Dim xlActiveWkb As Object
Dim xlActiveSheet As Object
Dim iCols, iRows, flag As Integer
Set db = CurrentDb
Set xlFile = CreateObject("Excel.Application")
Set xlWorkBook = xlFile.Workbooks.Add
Set xlActiveWkb = xlFile.Application.ActiveWorkBook
xlFile.Visible = True
xlActiveWkb.Sheets.Add
xlActiveWkb.Worksheets(1).Name = "My_Report"
Set xlActiveSheet = xlActiveWkb.Worksheets("My_Report")
Set rec1 = db.OpenRecordset("Report")
For iCols = 0 To rec1.Fields.Count - 1
xlActiveSheet.Cells(1, iCols + 1).Value = rec1.Fields(iCols).Name
If rec1.Fields(iCols).Name = "FS Number" Then
flag = iCols
End If
Next
xlActiveSheet.Range(xlActiveSheet.Cells(1, 1), xlActiveSheet.Cells(1, rec1.Fields.Count)).Font.Bold = True
xlActiveSheet.Range(xlActiveSheet.Cells(1, 1), xlActiveSheet.Cells(1, rec1.Fields.Count)).Interior.ColorIndex = 15
xlActiveSheet.Cells(2, 1).CopyFromRecordset rec1
xlActiveSheet.Columns("A:AD").EntireColumn.AutoFit
iRows = 1
rec1.MoveFirst
While Not rec1.EOF
xlActiveSheet.Cells(iRows + 1, flag + 1).Characters(InStr(rec1![FS Number], "*")).Font.ColorIndex = 3
iRows = iRows + 1
rec1.MoveNext
Wend
Set xlSheet = Nothing
Set xlWorkBook = Nothing
Set xlActiveWkb = Nothing
rec1.Close
db.Close
Set rec1 = Nothing
Set db = Nothing
End Sub
The magic is here
xlActiveSheet.Cells(iRows + 1, flag + 1).Characters(InStr(rec1![FS Number], "*")).Font.ColorIndex = 3