Running Excel Code from Access

F

Fester

OK, what I would like to do is run the following code from Access.
It's an Excel macro that I'd like to have stored in the DB so that a
user doesn't have to install anything. What is the easiest way to
accomplish this?

<CODE>
Dim RNGEND As String
Dim myRange As Range

ActiveSheet.Select

xls.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 = xls.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
xls.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 = xls.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
xls.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
< /CODE>

Any suggestions are greatly appreciated.
 
M

M Skabialka

Here's some code I adapted from some code written by Dev Ashish. It opens
the workbook and runs two different macros. Each one takes info from
another workbook and imports it getting ready to then transfer it to Access
as a table in another function not shown here.

'************* Code Start ****************
'Run Excel Macros through Automation
'This code was originally written by Dev Ashish
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Dev Ashish
'http://www.mvps.org/access/modules/mdl0007.htm
'
'NOTE: Note that in order for Access to recognize xlAutoOpen constant, you
need to reference Excel Object Library.
'
Function RunExcelMacros_CreateVehiclePartSheets()
Dim objXL As Object, x
On Error Resume Next
Set objXL = CreateObject("Excel.Application")

With objXL.Application
.Visible = False 'true to watch the process happen
'Open the Workbook
.Workbooks.Open "C:\ProductionManagement\ExcelToAccessImport.xls"
'Run AutoOpen
'NOTE: Note that in order for Access to recognize xlAutoOpen constant, you
need to reference Excel Object Library.
.ActiveWorkbook.RunAutoMacros xlAutoOpen
x = .Run("ExtractVehicleData") 'Create the Vehicle number
worksheet
End With

With objXL.Application
.Visible = False
'Open the Workbook
.Workbooks.Open "C:\ProductionManagement\ExcelToAccessImport.xls"
'Run AutoOpen
.ActiveWorkbook.RunAutoMacros xlAutoOpen
x = .Run("ExtractPartData") 'Create the Part number worksheet
End With

objXL.Save
objXL.Quit ' When you finish, use the Quit method to close
Set objXL = Nothing ' the application, then release the reference.
End Function
'************* Code End ****************

Hope this helps, this was a recent project I worked on.
Mich

Fester said:
OK, what I would like to do is run the following code from Access.
It's an Excel macro that I'd like to have stored in the DB so that a
user doesn't have to install anything. What is the easiest way to
accomplish this?

<CODE>
Dim RNGEND As String
Dim myRange As Range

ActiveSheet.Select

xls.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 = xls.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
xls.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 = xls.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
xls.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
< /CODE>

Any suggestions are greatly appreciated.
Click to expand...
 
F

Fester

Here's what I have so far in Access:

Public Sub ControlExcelFromAccess()
Dim strFile As String

strFile = "C:\Care360\ReqLog.xls"

' Opens Excel and makes it Visible
Set xlAPP = New Excel.Application
xlAPP.Visible = True
' Opens up a Workbook
Set xlWB = xlAPP.Workbooks.Open(strFile)
' Sets the Workseet to the last active sheet - Better to use the
commented version and use the name of the sheet.
Set xlWS = xlWB.ActiveSheet
' Set xlWS = xlWB("Sheet1")
With xlWS ' You are now working with the Named file and the named
worksheet

' Your Excel code begins here...

Dim RNGEND As String
Dim myRange As Range

' ActiveSheet.Select

xlAPP.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 = xlAPP.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
xlAPP.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 = xlAPP.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
xlAPP.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

End With

' Close and Cleanup

' xlWB.SaveAs 'xlSaveFile
' xlWB.Close
' xls.Quit
' Set xls = Nothing
End Sub

It opens the document, and then hangs.

Again, any help is appreciated.
 
F

Fester

Where are the Macros stored though?

The basic premise is that the user will open the DB, click a button,
and Access will open the xls file, run the code, and then save the
file (or hopefully in the future, import to a table in the DB.)

They won't have the macro installed anywhere, so how do I run the
macros that aren't installed yet?



Here's some code I adapted from some code written by Dev Ashish.  It opens
the workbook and runs two different macros.  Each one takes info from
another workbook and imports it getting ready to then transfer it to Access
as a table in another function not shown here.

'************* Code Start ****************
'Run Excel Macros through Automation
'This code was originally written by Dev Ashish
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Dev Ashish
'http://www.mvps.org/access/modules/mdl0007.htm
'
'NOTE: Note that in order for Access to recognize xlAutoOpen constant, you
need to reference Excel Object Library.
'
Function RunExcelMacros_CreateVehiclePartSheets()
Dim objXL As Object, x
    On Error Resume Next
    Set objXL = CreateObject("Excel.Application")

    With objXL.Application
        .Visible = False    'true to watch the process happen
        'Open the Workbook
        .Workbooks.Open "C:\ProductionManagement\ExcelToAccessImport.xls"
        'Run AutoOpen
'NOTE: Note that in order for Access to recognize xlAutoOpen constant, you
need to reference Excel Object Library.
        .ActiveWorkbook.RunAutoMacros xlAutoOpen
        x = .Run("ExtractVehicleData")   'Create the Vehicle number
worksheet
    End With

    With objXL.Application
        .Visible = False
        'Open the Workbook
        .Workbooks.Open "C:\ProductionManagement\ExcelToAccessImport.xls"
        'Run AutoOpen
        .ActiveWorkbook.RunAutoMacros xlAutoOpen
        x = .Run("ExtractPartData")      'Create the Partnumber worksheet
    End With

    objXL.Save
    objXL.Quit              ' When you finish, use the Quit method to close
    Set objXL = Nothing     ' the application, then release thereference.
End Function
'************* Code End ****************

Hope this helps, this was a recent project I worked on.
Mich


OK, what I would like to do is run the following code from Access.
It's an Excel macro that I'd like to have stored in the DB so that a
user doesn't have to install anything.  What is the easiest way to
accomplish this?
Click to expand...
<CODE>
   Dim RNGEND As String
   Dim myRange As Range
Click to expand...
       ActiveSheet.Select
Click to expand...
       xls.ScreenUpdating = False
Click to expand...
       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
Click to expand...
       'Renames Sheet, Adds Additional Sheet and Renames it Report
           ActiveSheet.Select
           ActiveSheet.Name = "REQ LOG"
Click to expand...
           Sheets("REQ LOG").Select
           Rows("1:2").Select
           Selection.Delete Shift:=xlUp
Click to expand...
       'Unmerges all Cells
           Cells.Select
           With Selection
               .Orientation = 0
               .AddIndent = False
               .ShrinkToFit = False
               .ReadingOrder = xlContext
               .MergeCells = False
           End With
Click to expand...
           Range("B4").Select
           With Selection.Borders(xlEdgeBottom)
               .LineStyle = xlContinuous
               .Weight = xlThin
               .ColorIndex = xlAutomatic
           End With
Click to expand...
           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
Click to expand...
       'Uses RNGEND to Calculate the Last Non-Blank Cell
Click to expand...
        Set myRange = Worksheets("REQ LOG").Range("A:A")
         RNGEND = xls.WorksheetFunction.CountA(myRange)
Click to expand...
       '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))))"
Click to expand...
       '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))))
Click to expand...
           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
           xls.CutCopyMode = False
           Selection.Delete Shift:=xlToLeft
           Range("B1").FormulaR1C1 = "OrderedTime"
           Range("C1").FormulaR1C1 = "OrderedDate"
Click to expand...
           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
Click to expand...
       'Uses RNGEND to Calculate the Last Non-Blank Cell
        Set myRange = Worksheets("REQ LOG").Range("A:A")
         RNGEND = xls.WorksheetFunction.CountA(myRange)
Click to expand...
           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))))"
Click to expand...
       '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))))
Click to expand...
           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
           xls.CutCopyMode = False
           Selection.Delete Shift:=xlToLeft
Click to expand...
       Range("B2:B" & RNGEND).Select
       Dim ORDTIMERNG As Range
       For Each ORDTIMERNG In Selection.Cells
           ORDTIMERNG.Value = ORDTIMERNG.Value
       Next ORDTIMERNG
Click to expand...
       Range("I2:I" & RNGEND).Select
       Dim PATARRTIMERNG As Range
       For Each PATARRTIMERNG In Selection.Cells
           PATARRTIMERNG.Value = PATARRTIMERNG.Value
       Next PATARRTIMERNG
Click to expand...
       Range("J2:J" & RNGEND).Select
       Dim COLLTIMERNG As Range
       For Each COLLTIMERNG In Selection.Cells
           COLLTIMERNG.Value = COLLTIMERNG.Value
       Next COLLTIMERNG
Click to expand...
       '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"
Click to expand...
       Range("A1").Select
       End If
  < /CODE>
Click to expand...
Any suggestions are greatly appreciated.
Click to expand...
Click to expand...
 
C

Clif McIrvin

Fester, all the examples supplied so far require that the user actually
have Excel installed.

--
Clif

Where are the Macros stored though?

The basic premise is that the user will open the DB, click a button,
and Access will open the xls file, run the code, and then save the
file (or hopefully in the future, import to a table in the DB.)

They won't have the macro installed anywhere, so how do I run the
macros that aren't installed yet?



Here's some code I adapted from some code written by Dev Ashish. It
opens
the workbook and runs two different macros. Each one takes info from
another workbook and imports it getting ready to then transfer it to
Access
as a table in another function not shown here.

'************* Code Start ****************
'Run Excel Macros through Automation
'This code was originally written by Dev Ashish
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Dev Ashish
'http://www.mvps.org/access/modules/mdl0007.htm
'
'NOTE: Note that in order for Access to recognize xlAutoOpen constant,
you
need to reference Excel Object Library.
'
Function RunExcelMacros_CreateVehiclePartSheets()
Dim objXL As Object, x
On Error Resume Next
Set objXL = CreateObject("Excel.Application")

With objXL.Application
.Visible = False 'true to watch the process happen
'Open the Workbook
.Workbooks.Open "C:\ProductionManagement\ExcelToAccessImport.xls"
'Run AutoOpen
'NOTE: Note that in order for Access to recognize xlAutoOpen constant,
you
need to reference Excel Object Library.
.ActiveWorkbook.RunAutoMacros xlAutoOpen
x = .Run("ExtractVehicleData") 'Create the Vehicle number
worksheet
End With

With objXL.Application
.Visible = False
'Open the Workbook
.Workbooks.Open "C:\ProductionManagement\ExcelToAccessImport.xls"
'Run AutoOpen
.ActiveWorkbook.RunAutoMacros xlAutoOpen
x = .Run("ExtractPartData") 'Create the Part number worksheet
End With

objXL.Save
objXL.Quit ' When you finish, use the Quit method to close
Set objXL = Nothing ' the application, then release the reference.
End Function
'************* Code End ****************

Hope this helps, this was a recent project I worked on.
Mich


OK, what I would like to do is run the following code from Access.
It's an Excel macro that I'd like to have stored in the DB so that a
user doesn't have to install anything. What is the easiest way to
accomplish this?
Click to expand...
<CODE>
Dim RNGEND As String
Dim myRange As Range

xls.ScreenUpdating = False
Click to expand...
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
Click to expand...
'Renames Sheet, Adds Additional Sheet and Renames it Report
ActiveSheet.Select
ActiveSheet.Name = "REQ LOG"
Click to expand...
Sheets("REQ LOG").Select
Rows("1:2").Select
Selection.Delete Shift:=xlUp
Click to expand...
'Unmerges all Cells
Cells.Select
With Selection
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Click to expand...
Range("B4").Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Click to expand...
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
Click to expand...
'Uses RNGEND to Calculate the Last Non-Blank Cell
Click to expand...
Set myRange = Worksheets("REQ LOG").Range("A:A")
RNGEND = xls.WorksheetFunction.CountA(myRange)
Click to expand...
'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))))"
Click to expand...
'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))))
Click to expand...
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
xls.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("B1").FormulaR1C1 = "OrderedTime"
Range("C1").FormulaR1C1 = "OrderedDate"
Click to expand...
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
Click to expand...
'Uses RNGEND to Calculate the Last Non-Blank Cell
Set myRange = Worksheets("REQ LOG").Range("A:A")
RNGEND = xls.WorksheetFunction.CountA(myRange)
Click to expand...
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))))"
Click to expand...
'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))))
Click to expand...
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
xls.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Click to expand...
Range("B2:B" & RNGEND).Select
Dim ORDTIMERNG As Range
For Each ORDTIMERNG In Selection.Cells
ORDTIMERNG.Value = ORDTIMERNG.Value
Next ORDTIMERNG
Click to expand...
Range("I2:I" & RNGEND).Select
Dim PATARRTIMERNG As Range
For Each PATARRTIMERNG In Selection.Cells
PATARRTIMERNG.Value = PATARRTIMERNG.Value
Next PATARRTIMERNG
Click to expand...
Range("J2:J" & RNGEND).Select
Dim COLLTIMERNG As Range
For Each COLLTIMERNG In Selection.Cells
COLLTIMERNG.Value = COLLTIMERNG.Value
Next COLLTIMERNG
Click to expand...
'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"
Click to expand...
Range("A1").Select
End If
< /CODE>
Click to expand...
Any suggestions are greatly appreciated.
Click to expand...
Click to expand...
 
R

Ron2006

Instead of using the macro, use automation to execute the commands
from Access. (most excell actions can be executed from within access.)

Here is an example of executing excell actions from Access: (In this
scenario, two queries are exported into the spreadsheet, then this
code is executed to move pieces of the exported data into fairly
elaborately formated worksheets within the spreadsheet and then more
formating is applied to the spreadsheet. The whole process is part of
vba code on a button click within Access.)

=====================

Set es = CreateObject("Excel.Application")

es.Visible = False

es.Workbooks.Open FileName:=reportfilename

es.Sheets("MonthlySummary").Select
es.Range("A2:A2").Select
es.Selection.Copy
es.Sheets("EMEA IBR Master").Select
es.Range("C2").Select
es.ActiveSheet.Paste

es.Sheets("MonthlySummary").Select
es.Range("B2:B2").Select
es.Selection.Copy
es.Sheets("EMEA IBR Master").Select
es.Range("E2").Select
es.ActiveSheet.Paste

es.Sheets("MonthlySummary").Select
es.Range("C2:C2").Select
es.Selection.Copy
es.Sheets("EMEA IBR Master").Select
es.Range("K2").Select
es.ActiveSheet.Paste

es.Sheets("MonthlySummary").Select
es.Range("D2:D2").Select
es.Selection.Copy
es.Sheets("EMEA IBR Master").Select
es.Range("K3").Select
es.ActiveSheet.Paste

es.Range("K2:K3").Select
es.Selection.Font.Bold = True

es.Sheets("IBRMonthlyExport").Select
es.Range("B2:AP300").Select

With es.Selection.Font
.Name = "Tahoma"
.FontStyle = "Regular"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With

es.Selection.Copy
es.Sheets("EMEA IBR Master").Select
es.Range("A6").Select
es.ActiveSheet.Paste

es.Sheets("IBRMonthlyExport").Select
es.Range("AA1:AP1").Select
es.Selection.Copy
es.Sheets("EMEA IBR Master").Select
es.Range("Z5").Select
es.ActiveSheet.Paste

es.Range("A5").Select
es.ActiveCell.FormulaR1C1 = "SR #"

es.Range("A1").Select
es.ActiveCell.FormulaR1C1 = "Exported On:"
es.Range("A2").Select
es.ActiveCell.FormulaR1C1 = Now()

es.Range("A6:AE300").Select
es.Selection.Rows.AutoFit

es.Columns("P:p").Select
es.Selection.ColumnWidth = 14
es.Columns("Q:Q").Select
es.Selection.ColumnWidth = 38
es.Columns("R:W").Select
es.Selection.ColumnWidth = 38

es.Range("A1:BB300").Select
es.Selection.Copy
es.Sheets(Format(Month(Enddate), "00") & " EMEA IBR").Select
es.Range("A1").Select
es.ActiveSheet.Paste

es.Range("A6:AE300").Select
es.Selection.Rows.AutoFit
es.Columns("P:p").Select
es.Selection.ColumnWidth = 14
es.Columns("Q:Q").Select
es.Selection.ColumnWidth = 38
es.Columns("R:S").Select
es.Selection.ColumnWidth = 28

es.Sheets("IBRMonthlyExport").Select
es.ActiveWindow.SelectedSheets.Delete

es.Sheets(Format(Month(Enddate), "00") & " EMEA IBR").Select

es.Columns("Q:W").Select
es.Selection.WrapText = True
es.Cells.Select
es.Selection.Rows.AutoFit
es.Range("A1:A1").Select
es.ActiveWorkbook.Save
es.ActiveWorkbook.Close (False)

es.Application.Quit
Set es = Nothing

=================================

Ron
 
F

Fester

Sorry, what I meant was they didn't have the Macros installed. Excel
is installed on all PC's.


Fester, all the examples supplied so far require that the user actually
have Excel installed.

--
Clif


Where are the Macros stored though?

The basic premise is that the user will open the DB, click a button,
and Access will open the xls file, run the code, and then save the
file (or hopefully in the future, import to a table in the DB.)

They won't have the macro installed anywhere, so how do I run the
macros that aren't installed yet?

Here's some code I adapted from some code written by Dev Ashish. It
opens
the workbook and runs two different macros. Each one takes info from
another workbook and imports it getting ready to then transfer it to
Access
as a table in another function not shown here.
Click to expand...
'************* Code Start ****************
'Run Excel Macros through Automation
'This code was originally written by Dev Ashish
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Dev Ashish
'http://www.mvps.org/access/modules/mdl0007.htm
'
'NOTE: Note that in order for Access to recognize xlAutoOpen constant,
you
need to reference Excel Object Library.
'
Function RunExcelMacros_CreateVehiclePartSheets()
Dim objXL As Object, x
On Error Resume Next
Set objXL = CreateObject("Excel.Application")
Click to expand...
With objXL.Application
.Visible = False 'true to watch the process happen
'Open the Workbook
.Workbooks.Open "C:\ProductionManagement\ExcelToAccessImport.xls"
'Run AutoOpen
'NOTE: Note that in order for Access to recognize xlAutoOpen constant,
you
need to reference Excel Object Library.
.ActiveWorkbook.RunAutoMacros xlAutoOpen
x = .Run("ExtractVehicleData") 'Create the Vehicle number
worksheet
End With
Click to expand...
With objXL.Application
.Visible = False
'Open the Workbook
.Workbooks.Open "C:\ProductionManagement\ExcelToAccessImport.xls"
'Run AutoOpen
.ActiveWorkbook.RunAutoMacros xlAutoOpen
x = .Run("ExtractPartData") 'Create the Part number worksheet
End With
Click to expand...
objXL.Save
objXL.Quit ' When you finish, use the Quit method to close
Set objXL = Nothing ' the application, then release the reference.
End Function
'************* Code End ****************
Click to expand...
Hope this helps, this was a recent project I worked on.
Mich
Click to expand...
news:f2449cae-fdaa-447f-a8ee-37722bee289e@d34g2000vbm.googlegroups.com....
Click to expand...
OK, what I would like to do is run the following code from Access.
It's an Excel macro that I'd like to have stored in the DB so that a
user doesn't have to install anything. What is the easiest way to
accomplish this?
<CODE>
Dim RNGEND As String
Dim myRange As Range
ActiveSheet.Select
xls.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 = xls.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
xls.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 = xls.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
xls.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
< /CODE>
Any suggestions are greatly appreciated.
Click to expand...
Click to expand...
Click to expand...
 
C

Clif McIrvin

Sorry, what I meant was they didn't have the Macros installed. Excel
is installed on all PC's.

In that case, you can revise your macro code (per Ron's reply) and put
the code directly into Access.
 
M

M Skabialka

In my case I wanted to move some information from a workbook1 to Access.
So that I wouldn't mess up workbook1, I created a new workbook2
(ExcelToAccessImport.xls) and created macros in it to copy data from
workbook1 and manipulate it to make it easier to transfer into Access. e.g
I had to transform some data.
My code in Access opens workbook2 and runs the macros which go out to the
workbook1 and bring data back into workbook2. Further code in Access then
transfers workbook2 data into Access tables.
So the Excel macros are in workbook2, and there is code in Access to
transfer complete worksheets to Access tables.
I did it this way becuase I was unfamiliar with Excel code, and used the
Record macro function in Excel to create the code I needed, cleaning it up
once I got the hang of it.

Ron's method moves the macro to Access and performs the actions from there.

Mich

Where are the Macros stored though?

The basic premise is that the user will open the DB, click a button,
and Access will open the xls file, run the code, and then save the
file (or hopefully in the future, import to a table in the DB.)

They won't have the macro installed anywhere, so how do I run the
macros that aren't installed yet?



Here's some code I adapted from some code written by Dev Ashish. It opens
the workbook and runs two different macros. Each one takes info from
another workbook and imports it getting ready to then transfer it to
Access
as a table in another function not shown here.

'************* Code Start ****************
'Run Excel Macros through Automation
'This code was originally written by Dev Ashish
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Dev Ashish
'http://www.mvps.org/access/modules/mdl0007.htm
'
'NOTE: Note that in order for Access to recognize xlAutoOpen constant, you
need to reference Excel Object Library.
'
Function RunExcelMacros_CreateVehiclePartSheets()
Dim objXL As Object, x
On Error Resume Next
Set objXL = CreateObject("Excel.Application")

With objXL.Application
.Visible = False 'true to watch the process happen
'Open the Workbook
.Workbooks.Open "C:\ProductionManagement\ExcelToAccessImport.xls"
'Run AutoOpen
'NOTE: Note that in order for Access to recognize xlAutoOpen constant, you
need to reference Excel Object Library.
.ActiveWorkbook.RunAutoMacros xlAutoOpen
x = .Run("ExtractVehicleData") 'Create the Vehicle number
worksheet
End With

With objXL.Application
.Visible = False
'Open the Workbook
.Workbooks.Open "C:\ProductionManagement\ExcelToAccessImport.xls"
'Run AutoOpen
.ActiveWorkbook.RunAutoMacros xlAutoOpen
x = .Run("ExtractPartData") 'Create the Part number worksheet
End With

objXL.Save
objXL.Quit ' When you finish, use the Quit method to close
Set objXL = Nothing ' the application, then release the reference.
End Function
'************* Code End ****************

Hope this helps, this was a recent project I worked on.
Mich


OK, what I would like to do is run the following code from Access.
It's an Excel macro that I'd like to have stored in the DB so that a
user doesn't have to install anything. What is the easiest way to
accomplish this?
Click to expand...
<CODE>
Dim RNGEND As String
Dim myRange As Range

xls.ScreenUpdating = False
Click to expand...
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
Click to expand...
'Renames Sheet, Adds Additional Sheet and Renames it Report
ActiveSheet.Select
ActiveSheet.Name = "REQ LOG"
Click to expand...
Sheets("REQ LOG").Select
Rows("1:2").Select
Selection.Delete Shift:=xlUp
Click to expand...
'Unmerges all Cells
Cells.Select
With Selection
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Click to expand...
Range("B4").Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Click to expand...
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
Click to expand...
'Uses RNGEND to Calculate the Last Non-Blank Cell
Click to expand...
Set myRange = Worksheets("REQ LOG").Range("A:A")
RNGEND = xls.WorksheetFunction.CountA(myRange)
Click to expand...
'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))))"
Click to expand...
'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))))
Click to expand...
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
xls.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("B1").FormulaR1C1 = "OrderedTime"
Range("C1").FormulaR1C1 = "OrderedDate"
Click to expand...
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
Click to expand...
'Uses RNGEND to Calculate the Last Non-Blank Cell
Set myRange = Worksheets("REQ LOG").Range("A:A")
RNGEND = xls.WorksheetFunction.CountA(myRange)
Click to expand...
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))))"
Click to expand...
'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))))
Click to expand...
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
xls.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Click to expand...
Range("B2:B" & RNGEND).Select
Dim ORDTIMERNG As Range
For Each ORDTIMERNG In Selection.Cells
ORDTIMERNG.Value = ORDTIMERNG.Value
Next ORDTIMERNG
Click to expand...
Range("I2:I" & RNGEND).Select
Dim PATARRTIMERNG As Range
For Each PATARRTIMERNG In Selection.Cells
PATARRTIMERNG.Value = PATARRTIMERNG.Value
Next PATARRTIMERNG
Click to expand...
Range("J2:J" & RNGEND).Select
Dim COLLTIMERNG As Range
For Each COLLTIMERNG In Selection.Cells
COLLTIMERNG.Value = COLLTIMERNG.Value
Next COLLTIMERNG
Click to expand...
'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"
Click to expand...
Range("A1").Select
End If
< /CODE>
Click to expand...
Any suggestions are greatly appreciated.
Click to expand...
Click to expand...
 
M

M Skabialka

Do you know what line the code is stopping at?
And the error code or description?
Mich

Fester said:
Here's what I have so far in Access:

Public Sub ControlExcelFromAccess()
Dim strFile As String

strFile = "C:\Care360\ReqLog.xls"

' Opens Excel and makes it Visible
Set xlAPP = New Excel.Application
xlAPP.Visible = True
' Opens up a Workbook
Set xlWB = xlAPP.Workbooks.Open(strFile)
' Sets the Workseet to the last active sheet - Better to use the
commented version and use the name of the sheet.
Set xlWS = xlWB.ActiveSheet
' Set xlWS = xlWB("Sheet1")
With xlWS ' You are now working with the Named file and the named
worksheet

' Your Excel code begins here...

Dim RNGEND As String
Dim myRange As Range

' ActiveSheet.Select

xlAPP.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 = xlAPP.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
xlAPP.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 = xlAPP.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
xlAPP.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

End With

' Close and Cleanup

' xlWB.SaveAs 'xlSaveFile
' xlWB.Close
' xls.Quit
' Set xls = Nothing
End Sub

It opens the document, and then hangs.

Again, any help is appreciated.
Click to expand...
 

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

Similar Threads

Running an Excel Macro from Access 6
Macro Loop 1
Different Results from the Same Macro 2
Copying Data Down the Column But Only Based on What's in Column A 1
Replace a fixed number with a variable via popup 3
Complie Syntax Error 6
Check values before running macro 8
Macro should Save and Overwrite file 1

Top