View Full Version : Running an Excel Macro from Access


brendon
08-03-2009, 11:20 AM
Hello, new to the forums here. I was wondering how one would do the following?

Open Excel,
Open a spreadsheet,
Run and Excel Macro,
Save the File as something else.

I can get Access to open the spreadsheet, and it looks like it's running the macro, but it's not. Here's the code I have so far:

Private Sub Command22_Click()
Dim xls As Object, xwkb As Object
Dim strFile As String, strMacro As String
strFile = "ReqLog.xls"
strMacro = "ADDTOACCESS"

Set xls = CreateObject("Excel.Application")
xls.Visible = True
Set xwkb = xls.Workbooks.Open("C:\Care360\" & strFile)
xls.Run strFile & "!" & "ThisWorkbook" & "." & strMacro
xwkb.Close False
Set xwkb = Nothing
xls.Quit
Set xls = Nothing

End SubOtherwise, is there a way to do the following through Access instead of Excel? As in, import the file, run the code below (in Access VBA), and then save to a pre-existing table?

Sub ADDTOACCESS()
Dim RNGEND As String
Dim myRange As Range

Application.ScreenUpdating = False

Range("BB1").Activate
If ActiveCell.Formula = "COMPILED" Then
MsgBox "Data Has Already Been Analyzed.", (vbExclamation), "I'm Sorry But . . ."
Range("A1").Select
GoTo endhere
Else

'Renames Sheet, Adds Additional Sheet and Renames it Report
ActiveSheet.Select
ActiveSheet.Name = "REQ LOG"

Sheets("REQ LOG").Select
Rows("1:2").Select
Selection.Delete Shift:=xlUp

'Unmerges all Cells
Cells.Select
With Selection
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With


Range("B4").Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

Range("A2:S10000").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Copies Time to each cell for all tests per patient

'Uses RNGEND to Calculate the Last Non-Blank Cell

Set myRange = Worksheets("REQ LOG").Range("A:A")
RNGEND = Application.WorksheetFunction.CountA(myRange)

'Updates Ordered Time to Military Time
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
' Selection.Insert Shift:=xlToRight
Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISBLANK(RC[-1]),"""",IF(MID(RC[-1],12,2)=""12"",MID(RC[-1],12,5),IF(RIGHT(RC[-1],2)=""PM"",MID(RC[-1],12,2)+12&MID(RC[-1],14,3),MID(RC[-1],12,5))))"

'Excel Code for Above
'=IF(ISBLANK(B2),"",IF(MID(B2,12,2)="12",MID(B2,12,5),IF(RIGHT(B2,2)="PM",MID(B2,12,2)+12&MID(B2,14,3),MID(B2,12,5))))

Range("C2").Select
Selection.AutoFill Destination:=Range("C2:C" & RNGEND), Type:=xlFillDefault
Range("C2:C" & RNGEND).Select
Range("D2").FormulaR1C1 = "=IF(ISBLANK(RC[-2]),"""",LEFT(RC[-2],11))"
Range("D2").Select
Selection.AutoFill Destination:=Range("D2:D" & RNGEND), Type:=xlFillDefault
Range("D2:D" & RNGEND).Select
Columns("C:D").Select
Selection.Copy
Columns("C:D").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("B1").FormulaR1C1 = "OrderedTime"
Range("C1").FormulaR1C1 = "OrderedDate"

Columns("F:G").Select
Selection.Delete Shift:=xlToLeft
Columns("G:G").Select
Selection.Delete Shift:=xlToLeft
Columns("I:M").Select
Selection.Delete Shift:=xlToLeft
Columns("J:K").Select
Selection.Delete Shift:=xlToLeft


'Uses RNGEND to Calculate the Last Non-Blank Cell
Set myRange = Worksheets("REQ LOG").Range("A:A")
RNGEND = Application.WorksheetFunction.CountA(myRange)

Range("K2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISBLANK(RC[-1]),"""",IF(MID(RC[-1],12,2)=""12"",MID(RC[-1],12,5),IF(RIGHT(RC[-1],2)=""PM"",MID(RC[-1],12,2)+12&MID(RC[-1],14,3),MID(RC[-1],12,5))))"

'Excel Code for Above
'=IF(ISBLANK(B2),"",IF(MID(B2,12,2)="12",MID(B2,12,5),IF(RIGHT(B2,2)="PM",MID(B2,12,2)+12&MID(B2,14,3),MID(B2,12,5))))

Range("K2").Select
Selection.AutoFill Destination:=Range("K2:K" & RNGEND), Type:=xlFillDefault
Range("K2:K" & RNGEND).Select
Columns("K:K").Select
Selection.Copy
Columns("J:J").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("K:Z").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft

Range("B2:B" & RNGEND).Select
Dim ORDTIMERNG As Range
For Each ORDTIMERNG In Selection.Cells
ORDTIMERNG.Value = ORDTIMERNG.Value
Next ORDTIMERNG

Range("I2:I" & RNGEND).Select
Dim PATARRTIMERNG As Range
For Each PATARRTIMERNG In Selection.Cells
PATARRTIMERNG.Value = PATARRTIMERNG.Value
Next PATARRTIMERNG

Range("J2:J" & RNGEND).Select
Dim COLLTIMERNG As Range
For Each COLLTIMERNG In Selection.Cells
COLLTIMERNG.Value = COLLTIMERNG.Value
Next COLLTIMERNG

'Add Headings
Range("A1").FormulaR1C1 = "Facility"
Range("B1").FormulaR1C1 = "OrdTime"
Range("C1").FormulaR1C1 = "OrdDate"
Range("D1").FormulaR1C1 = "ReqNum"
Range("E1").FormulaR1C1 = "PatientName"
Range("F1").FormulaR1C1 = "Phleb"
Range("G1").FormulaR1C1 = "Physician"
Range("H1").FormulaR1C1 = "OrdTests"
Range("I1").FormulaR1C1 = "PatArrTime"
Range("J1").FormulaR1C1 = "CollectionTime"

Range("A1").Select
End If
endhere:
End SubThank You in advance for any help.

Mr. B
08-03-2009, 01:52 PM
Here is a link that should be helpful to you:

http://www.mvps.org/access/modules/mdl0007.htm

Mike375
08-03-2009, 04:00 PM
I have not done any for Excel but do them for Word and I think similar to the link Dr B posted. The following is one mine and as you can see conditions/data on the Access form determine which one runs.

If Forms!GoToWord!Combo23 Like "Blue" Then

WordObj.Run "Macro10a"

End If

If Forms!GoToWord!Combo23 Like "Gold" Then

WordObj.Run "Macro10"

End If

If Forms!GoToWord!Combo23 Like "White" Then

WordObj.Run "Macro10b"

End If