Running an Excel Macro from Access

F

Fester

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:

Code:
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 Sub


Otherwise, 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?

Code:
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 Sub

Thank You in advance for any help.
 
C

Clifford Bass

Hi,

The Run requires a function, not a sub, and it should be public. Try
changing your macro declaration to this:

Public Function ADDTOACCESS()

Also, I do not think you can preface the macro name with the file name,
but am not totally sure. Try changing run your line to this:

xls.Run "ThisWorkbook" & "." & strMacro

Or, you may be able to do this:

Public Sub ADDTOACCESS()

And this:

xwkb.ADDTOACCESS

Clifford Bass

Fester said:
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:

Code:
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 Sub
[snip]
 
K

Ken Snell [MVP]

Clifford Bass said:
Also, I do not think you can preface the macro name with the file
name,
but am not totally sure.

Yes, you can precede the maro name with the file name -- in fact, it often
is needed if there are multiple EXCEL files open (including the PERSONAL.xls
file that usually opens hidden for EXCEL).
 
K

Ken Snell [MVP]

To save the work done by the EXCEL macro in the EXCEL file, change this code
line in the "run macro from ACCESS" code:
xwkb.Close False

to this:
xwkb.Close True

--

Ken Snell
<MS ACCESS MVP>
http://www.accessmvp.com/KDSnell/


Fester said:
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:

Code:
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 Sub


Otherwise, 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?

Code:
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 Sub

Thank You in advance for any help.
 
F

Fester

"Clifford Bass" <[email protected]> wrote in message
Thank You Clifford and Ken.

My next step is to somehow incorporate the Excel Macro into Access so
that the end user doesn't have to have it loaded on their machine, it
just runs through Access.

Any suggestions on where I could start to get information on that?
 
C

Clifford Bass

Hi Fester,

When I have converted Excel "macros" (really VBA code), all I have just
taken the code as is, added an Excel.Application object along with a With /
End With construct and placed the period at the beginning of each line that
is an Excel command.

Public Sub SomeSub()

Dim appExcel As Excel.Application
Dim fso As New FileSystemObject
Dim strFileName As String

strFileName = "C:\Temp\Output.xls"

Set appExcel = New Excel.Application
With appExcel
.Visible = True
.Workbooks.Add

.ActiveSheet.Name = "Key"
.Range("A1").Select
.ActiveCell.FormulaR1C1 = "KEY TO WORKSHEET NAMES"
.ActiveCell.Font.Bold = True
.Range("A3").Select
.ActiveCell.FormulaR1C1 = "All = Analyses by aggregate class data"

' etc.

If fso.FileExists(strFileName) Then
fso.DeleteFile strFileName
End If

.ActiveWorkbook.SaveAs strFileName, xlExcel7
.Quit
End With
Set appExcel = Nothing

End Sub

Hope that helps,

Clifford Bass
 

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

Top