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:
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?
Thank You in advance for any help.
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.