Sub NewExcelWithWorkbook() Dim oXL As Object 'This is needed to open a new instance of Excel. 'Without it, the file is only opened as a new Window Dim OpenFileName '<-this isn't used Dim testFileFind As String Dim oWB As Workbook Dim cl As Range 'This reads the cell 1 column to the Left so the path & file name can be read Set cl = ActiveCell.Offset(0, -1) 'The following tests for a blank cell and ends processing 'It is needed because dir() function will not work with a blank. If Len(Trim(cl)) = 0 Then MsgBox "You have not entered a Path and File name." End End If 'The following tests for the existance of the file testFileFind = Dir(cl) 'If the file is not found there will be nothing in the variable and processing ends. If Len(testFileFind) = 0 Then MsgBox "Invalid selection." & Chr(13) & _ "Filename " & cl.Value & " not found" End End If 'HERE IS MY PROBLEM - - - - - - - - - - - - - - - - - - - - - - - - - - - 'THIS TESTS TO SEE IF THE FILE IS ALREADY OPEN OR NOT If FileAlreadyOpen("cl") = True Then MsgBox "File is already open" End Else End If 'THIS LINE OF CODE OPENS THE NEW INSTANCE OF EXCEL. Set oXL = CreateObject("Excel.Application") 'THIS LINE OF CODE MAKES THE NEW INSTANCE OF EXCEL VISIBLE. oXL.Visible = True Set oWB = oXL.Workbooks.Open(cl) End SubPlease take note: The path and file name constantly change.
Function FileAlreadyOpen(FullFileName As String) As Boolean ' returns True if FullFileName is currently in use by another process ' example: If FileAlreadyOpen("C:FolderNameFileName.xls") Then... Dim f As Integer f = FreeFile On Error Resume Next Open FullFileName For Binary Access Read Write Lock Read Write As #f Close #f ' If an error occurs, the document is currently open. If Err.Number <> 0 Then FileAlreadyOpen = True Err.Clear 'MsgBox "Error #" & Str(Err.Number) & " - " & Err.Description Else FileAlreadyOpen = False End If On Error GoTo 0 End Function
Private Sub CommandButton2_Click() Dim WbBook1 As Worksheet Dim WbBook2 As Worksheet Dim sPath As String sPath = "Nymas01financeBudgetBudget 2008ExportsPLATFORM.xls" If IsFileOpen(sPath) Then MsgBox "File is Open" GoTo ResumeProcess: Else Workbooks.Open (sPath) End If ResumeProcess: Set WbBook1 = Workbooks("PLATFORM.xls").Worksheets("PLATFORM") Set WbBook2 = Workbooks("License Fees_2008.xls").Worksheets("PLATFORM not in FRX") WbBook2.Range("A2:A" & Rows.Count).Formula = "=IF(ISBLANK(GROUPLIST!A3)," & Chr(34) & Chr(34) & ",IF(COUNTIF(PLATFORM.xls!$B:$B,GROUPLIST!A3)>0," & Chr(34) & Chr(34) & ",GROUPLIST!A3))" 'Dim eSheet As Worksheet 'Set eSheet = Sheets("PLATFORM not in FRX") 'x = eSheet.Rows.Count 'eSheet.Range("A2").Formula = "=IF(ISBLANK(GROUPLIST!A3),"",IF(COUNTIF(PLATFORM.xls!$B:$B,GROUPLIST!A3)>0,"",GROUPLIST!A3))" 'eSheet.Range("A2:A" & x).FillDown Workbooks("PLATFORM.xls").Close End Sub Function IsFileOpen(filename As String) Dim filenum As Integer, errnum As Integer On Error Resume Next ' Turn error checking off. filenum = FreeFile() ' Get a free file number. ' Attempt to open the file and lock it. Open filename For Input Lock Read As #filenum Close filenum ' Close the file. errnum = Err ' Save the error number that occurred. On Error GoTo 0 ' Turn error checking back on. ' Check to see which error occurred. Select Case errnum ' No error occurred. ' File is NOT already open by another user. Case 0 IsFileOpen = False ' Error number for "Permission Denied." ' File is already opened by another user. Case 70 IsFileOpen = True ' Another error occurred. Case Else Error errnum End Select End Function
'This line of code Goes to below FUNCTION - Should NOT
The "testFileFind" in this line of code is blank after going to Function. Earlier in the routine the "testFileFind" still holds the file name.
I think this is where the problem is.
'TO HERE - - - - - - - - - - - - - -
'THIS LINE OF CODE OPENS THE NEW INSTANCE OF EXCEL.
Set oXL = CreateObject("Excel.Application") 'THIS LINE OF CODE MAKES THE NEW INSTANCE OF EXCEL VISIBLE. oXL.Visible = True Set oWB = oXL.Workbooks.Open("c:extrafilesmiscexcelLinkMenu.xls")
End Else MsgBox "File " & "testfilefind" & "is already open." End If'TO HERE - - - - - - - - - - - - - - -
When the requested file is already open, the routine should stop here with a message stating that the file is already open.I sure hope that someone can understand what I am talking about.
If the file is not open, the file should be opened and then the routine should stop.
In both instances, the routine goes to my Function below and comes up with an error.
I don't understand why it goes to this function.Function IsFileOpen(FileName As String) Dim iFilenum As Long Dim iErr As Long On Error Resume Next iFilenum = FreeFile() Open FileName For Input Lock Read As #iFilenum Close iFilenum iErr = Err On Error GoTo 0 Select Case iErr Case 0: IsFileOpen = False Case 70: IsFileOpen = True 'ADD THIS Case Else: Error iErr End Select End Function
Sub Send_info() Dim wbData As Workbook Dim wbArchive As Workbook Dim WS As Worksheet Set wbData = ActiveWorkbook Set wbArchive = Workbooks.Open("C:abc.xls") For Each WS In wbData.Worksheets WS.Range("A:G").Copy wbArchive.Sheets(WS.Name).Range("A1") Next WS End SubIs there a way I can add to this so that if the file is already open it will just paste the data and ONLY if it is closed it will open the file?
VB:which looks for a value in the selected cell and, if that value meets the citeria, presents the user with an open file dialogue. This works beautifully until the user choses to open an already open file. At this point Excel says ' this file is already open do you wish to open another copy'. Clicking yes opens a second copy and the macro proceeds but clicking no stops the macro in its tracks. What I would like is to change this code so that after clicking no the macro ends and presents a message box. Even better would be (though more complicated I suspect!) for the macro to test if the file is open first and then either open it and continue or continue using the already open version. Any hints?!If IsNumeric(ActiveCell.Value) = True And ActiveCell.Value > 100000 Then SetCurrentDirectoryA prometheus & ActiveCell.Value Application.FindFile MsgBox "Please select a valid job number", vbExclamation + vbOKOnly, "Open Job" Exit Sub End IfIf you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Dim oWB As Object Dim PWB As String Dim FSS As String PWB = ("c:MyMenuFilesMyMenuiJngo.xls") FSS = "MyMenuiJango.xls" 'First I need to check to see if "MyMenuiJango.xls" is open or not If FileAlreadyOpen("c:MyMenuFilesMyMenuiJango.xls") = True Then ActivateWorkbook (FSS) Application.Quit End Else
Sub OpenMyeMailNo1() Dim oShell Dim sUrl As String sUrl = "http://" & Sheets("Setup").Cells(8, 5).Value Set oShell = CreateObject("Wscript.Shell") oShell.Run (sUrl) End Sub
'open the access tool if not already open If Not IsFileOpen(strPath) Then 'IsFileOpen checks and returns true if file is already open depending on strPath (file path) 'close any open access instances Call CloseAllAccess Set oApp = CreateObject("Access.Application") oApp.AutomationSecurity = 1 oApp.OpenCurrentDatabase strPath oApp.Visible = True oApp.DoCmd.OpenTable "tbl_Material" oApp.DoCmd.OpenForm "frmCPanel" Set oApp = Nothing Else Set oApp = CreateObject("Access.Application") oApp.AutomationSecurity = 1 oApp.OpenCurrentDatabase strPath 'i am pretty sure this line shouldn;t be here, but i can;t figure what to put instead oApp.DoCmd.OpenTable "tbl_Material" oApp.DoCmd.OpenForm "frmCPanel" End IfThanks
VB:However, I am breaking on the highlighted code. The error is "Compile error: Invalid use of object".ExportNAV_CFFtest() rownum = Range("L60000").End(xlUp).Row Range(Cells(rownum - 3, 12), Cells(rownum, 12)).Select Application.CutCopyMode = False Selection.Copy Dim FundsSheet As Workbook Set FundsSheet = Workbooks.Open(Filename:="J:AdministrationAccountingFUNDSFUNDS-DailiesCurrentFunds.xls") If FundsSheet Is Nothing Then Workbooks.Open FundsSheet Range("G8").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=True [COLOR=lime]ElseIf FundsSheet Is Not Nothing[/COLOR] And FundsSheet.ReadOnly = False Then Range("G8").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=True ElseIf FundsSheet.ReadOnly Then MsgBox "Funds Sheet in Read-Only - Please Try Again" Err.Clear End If End SubIf you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
VB:FilePath = FileDir & MyChoice On Error Resume Next Set WordApp = CreateObject("Word.Application") Set WordDoc = WordApp.Documents.Open(Filename:=FilePath) WordApp.Visible = TrueIf you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
VB:End SubOpenSingleFile() 'Open an Excel workbook Dim Filter As String, Title As String, FileName As String Dim FilterIndex As Integer ' File filters Filter = "Excel Files(*.xls,*xlxs),*.xls,*xlxs" ' Default Filter to *.* FilterIndex = 3 ' Set Dialog Caption Title = "Select a File to Open" FileName = Application.GetOpenFilename(Filter, FilterIndex, Title ' Exit on Cancel If FileName = "False" Then MsgBox "No file was selected.", , "Select File" Exit Sub End If ' Open File If Not IsFileOpen(FileName) Then Workbooks.Open FileName '*** It will be the active workbook here b/c it was opened Else Message = "The file " & FileName & " is already open." vbResponse = MsgBox(Message, vbOKCancel, "Select file") '*** I need to activate it here if already open Workbooks(FileName).Activate ' doesn't work - subscript out or range error MsgBox "The active workbook is " & ActiveWorkbook.Name End IfIf you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
VB:[COLOR=red][COLOR=black]if [/COLOR]standings-2010.xls Is Not Open [COLOR=black]then[/COLOR]
VB:Workbook 'Check that Summary worksheet is available for update. Set wBook = Workbooks("CommittedSummary.xls") If wBook Is Nothing Then 'Not open 'Do nothing Else 'It is open i = MsgBox("The 'CommittedSummary.xls' workbook is already in use and cannot be updated. Please try again when the workbook Is available", _ vbCritical, "Committed Request Edit") Goto EndUpdate End IfIf you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines