The below code first checks if the required file is open, if it is open then use that file; if not, then open file from the path provided in the cell and read/write with that file. After completing the task, It further checks if the file path & name provided in the below cell is same or not, if same, then do nothing; if not, close the opened file without saving.
It works fine until the file path and name are same in the below cell. Throws an error when the file path and name is different in the below cell. It does not opens the file.
Not sure where am I going wrong. Can someone please help?
Asked Here - https://www.mrexcel.com/board/threads/open-file-if-not-already-open.1199858/
Asked here - https://chandoo.org/forum/threads/open-file-if-not-already-open.47763/
Sub RunQuery1()
Dim Lastrow As Long
Dim OpenBook_path, Available_File As String
Dim FileToOpen As Workbook
Dim wb As Workbook
Application.ScreenUpdating = False
Lastrow = ThisWorkbook.Sheets("Dashboard").Range("F" & Rows.Count).End(xlUp).Row
For i = 9 To Lastrow
OpenBook_path = ThisWorkbook.Sheets("Dashboard").Cells(i, 6) 'Path includes file name with extension
OpenBook_Sheet = ThisWorkbook.Sheets("Dashboard").Cells(i, 7)
OpenBook_Range = ThisWorkbook.Sheets("Dashboard").Cells(i, 8)
'Check if file is open,if open, then use open file; if not, open file from the path in the cell
Available_File = Dir(OpenBook_path) 'extracts the file name from the path
If Not wbOpen(Available_File, wb) Then Set FileToOpen = Workbooks.Open(OpenBook_path)
'open workbook from the path in the cell
With FileToOpen
'Copy range from the sheet
With Sheets(OpenBook_Sheet)
.Range(OpenBook_Range).Select 'Do something
End With
End With
'Check if Below File Path & Name are same
If ThisWorkbook.Sheets("Dashboard").Cells(i, 6) = ThisWorkbook.Sheets("Dashboard").Cells(i + 1, 6) Then
Else
FileToOpen.Close False
End If
Next i
Application.ScreenUpdating = True
End Sub
Function wbOpen(wbName As String, wbO As Workbook) As Boolean
On Error Resume Next
Set wbO = Workbooks(wbName)
wbOpen = Not wbO Is Nothing
End Function
Related
I am looking for a code to search a directory for specific file names with a changing number at the end of the name (File_1.xls, File_2.xls, File_3.xls, etc.) and stack the data within the reports on top of eachother without headers into a tab but if a File_Amend.xls file exists then it will only copy the data from that file and paste it into it's own tab. The only changing part of the File_ is 1,2,3, etc. or Amend. Everything ends in .xls
I've gotten this far:
Sub SaveFile()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet
Dim File As String
Dim wsCopy As Worksheet
Dim wsCopy2 As Worksheet
Dim wsCopy3 As Worksheet
Dim wsPaste As Worksheet
' For this part I am looking to have the file name constant as "File_" and then have the code search for files with the numbers 1,2,3,4, etc. instead of hardcoding in the file name
File = "L:\Main\Code\"
Set wsCopy = File & wb.Sheets("Main").Range("C6") 'this value is "File 1.xls"
Workbooks.Open Filename:=wsCopy, ReadOnly:=True
Set wsCopy2 = File & wb.Sheets("Main").Range("C7") 'this value is "File 2.xls"
Workbooks.Open Filename:=wsCopy2, ReadOnly:=True
Set wsCopy3 = File & wb.Sheets("Main").Range ("C8") 'this value is "File Amend.xls"
Workbooks.Open Filename:=wsCopy3, ReadOnly:=True
Set wb = Workbooks.Add
Set wsPaste = wb.Sheets(1)
If Dir(wsCopy) = True Then
wsCopy.Range ("A:I").Copy
wsPaste.Cells.PasteSpecial Paste:=xlPasteValues
If Dir(wsCopy2) = True Then
wsCopy2.UsedRange.Offset(1,0).SpecialCells(xlCellTypeVisible).Copy
wsPaste.Cells (Rows.Count, "A").End(x1Up).Offset (1, 0).PasteSpecial Paste: xlPasteValues
If Dir(wsCopy3) = True Then
wsPaste.Cells.ClearContents
wsCopy3.Range("A:I").Copy
wsPaste.Range("Al").PasteSpecial Paste:=xlPasteValues
End Sub
For searching filenames with different numbers, you can use different constant "File", and FOR loop.
Special check for File_Amend.xls can be put before the above code, all like this:
If Dir ("L:\Main\Code\File_Amend.xls" = True then
...
Else
File = "L:\Main\Code\File_"
For i = 1 to 99
wsCopy = File & i & ".xls"
...
Next i
End if
This question already has answers here:
Run Excel Macro from Outside Excel Using VBScript From Command Line
(8 answers)
Closed 3 months ago.
This post was edited and submitted for review 3 months ago and failed to reopen the post:
Original close reason(s) were not resolved
I am trying to call a VBA function from VBS script:
VBA
Function f_split_master_file(output_folder_path As String, master_excel_file_path As String) As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo ErrorHandler
Dim wb As Workbook
Dim output As String
' Variables related with the master excel file
Dim wb_master As Workbook
Dim ws_master As Worksheet
Dim master_range As Range
Dim responsible_names_range As Range
Dim responsible_name As Range
Dim last_row_master As Integer
' Variables related with the responsible name excel
Dim savepath As String
Dim wb_name As Workbook
Dim ws_name As Worksheet
Dim name As Variant
' Check whether master file exists
If Len(Dir(master_excel_file_path)) = 0 Then ' Master file does not exist
Err.Raise vbObjectError + 513, "Sheet1::f_split_master_file()", "Incorrect Master file path, file does not exist!"
End If
' Check whether output folder exists
If Dir(output_folder_path, vbDirectory) = "" Then ' Output folder path does not exist
Err.Raise vbObjectError + 513, "Sheet1::f_split_master_file()", "Incorrect output folder path, directory does not exist!"
End If
Set wb_master = Workbooks.Open(master_excel_file_path)
Set ws_master = wb_master.Sheets(1)
last_row_master = ws_master.Cells(Rows.Count, "AC").End(xlUp).row
Set master_range = ws_master.Range("A1:AD" & last_row_master)
Set responsible_names_range = ws_master.Range("AC2:AC" & last_row_master) ' Get all names
data = get_unique_responsibles(responsible_names_range) 'Call function to get an array containing distict names (column AC)
For Each name In data
'Create wb with name
savepath = output_folder_path & "\" & name & ".xlsx"
Workbooks.Add
ActiveWorkbook.SaveAs savepath
Set wb_name = ActiveWorkbook
Set ws_name = wb_name.Sheets(1)
master_range.AutoFilter 29, Criteria1:=name, Operator:=xlFilterValues
master_range.SpecialCells(xlCellTypeVisible).Copy
ws_name.Range("A1").PasteSpecial Paste:=xlPasteAll
wb_name.Close SaveChanges:=True
' Remove filters and save workbook
Application.CutCopyMode = False
ws_master.AutoFilterMode = False
Next name
CleanUp:
' Close all wb and enable screen updates and alerts
For Each wb In Workbooks
If wb.name <> ThisWorkbook.name Then
wb.Close
End If
Next wb
Application.ScreenUpdating = True
Application.DisplayAlerts = True
f_split_master_file = output ' empty string if successful execution
Exit Function
ErrorHandler:
' TODO: Log to file
' Err object is reset when it exits from here IMPORTANT!
output = Err.Description
Resume CleanUp
End Function
VBS
Set excelOBJ = CreateObject("Excel.Application")
Set workbookOBJ = excelOBJ.Workbooks.Open("C:\Users\aagir\Desktop\BUDGET_AND_FORECAST\Macro_DoNotDeleteMe_ANDONI.xlsm")
returnValue = excelOBJ.Run("sheet1.f_split_master_file","C:\Users\aagir\Desktop\NON-EXISTENT-DIRECTORY","C:\Users\aagir\Desktop\MasterReport_29092022.xlsx")
workbookOBJ.Close
excelOBJ.Quit
msgbox returnValue
The macro (VBA function) works fine. The only thing that I am missing is within the VBS script. When I call the vba function from vbs script it runs fine but I cannot get the return value in the "returnValue" variable defined in VBS (it does not show anything). Can anyone tell what I am doing wrong? Thanks!
Based on the name sheet1 (in your VBS script), I'm assuming the f_split_master_file Function is in a Worksheet module. Move it to a standard Module and change sheet1 to (eg) Module1 and then try again.
Source column contains a string in each cell. There are 4000+ cells. These need to be copied and pasted into a worksheet of the active (one that invoked the macro) workbook. Source workbook should be selected by the user using a search/browse pop-up box.
The below code does something close to my intended goal, but the directory as you see is static which is unacceptable. Maximum flexibility should be had with user choosing the source file manually. Furthermore I want to prevent the file path from becoming obsolete every time folders/files get renamed/shifted. Something tell me Application.GetOpenFilename() should be used, but how to correctly implement it?
Having little experience with the VBA, my attempts to mod this macro failed, so I'm asking for your advice on this matter. Again, the below code works well, but it's not flexible enough to be practical.
Edit: the problem is solved. See the final working code.
'MACRO TO READ-IN EXTERNAL EXCEL FILE FROM WHICH JOB NO.'S ARE EXTRACTED INTO USERFORM
Sub ReadDataFromCloseFile()
'IN CASE OF ERROR SEND TO ERROR FUNCTION
On Error GoTo ErrHandler
'PREVENT OPENED EXCEL SOURCE FILE FROM SHOWING TO USER
Application.ScreenUpdating = False
'OPEN SOURCE EXCEL WORKBOOK IN "READ ONLY MODE"
Dim SrcName As String
Dim src As Workbook
SrcName = Application.GetOpenFilename()
Set src = Workbooks.Open(SrcName, True, True)
'GET THE TOTAL ROWS FROM THE SOURCE WORKBOOK
Dim iTotalRows As Integer
iTotalRows = src.Worksheets("PROJECT LIST").Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).Rows.Count
'COPY DATA FROM SOURCE WORKBOOK -> DESTINATION WORKBOOK
Dim iCnt As Integer '(COUNTER)
For iCnt = 1 To iTotalRows
Worksheets("Test_File_8").Range("B" & (iCnt + 1)).Formula = src.Worksheets("PROJECT LIST").Range("A" & (iCnt + 1)).Formula
Next iCnt
'CLOSE THE SOURCE WORKBOOK FILE
src.Close False 'FALSE = DONT SAVE THE SOURCE FILE
Set src = Nothing 'FLUSH DATA
'ERROR FUNCTION
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
See my changes below. I added two variables X and strSrc. X is a variant that is used to loop through .SelectedItems and strSrc is that string that ultimately holds the path.
Sub ReadDataFromCloseFile()
'Set variable to hold workbook path and workbook path string
Dim X as Variant
Dim strSrc as String
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "" ' You can provide a base path here
.Title = "Select file."
.AllowMultiSelect = False
If .Show = -1 Then
For Each X In .SelectedItems
strSrc = X
Exit For
Next X
End If
End With
'IN CASE OF ERROR SEND TO ERROR FUNCTION
'On Error GoTo ErrHandler
'PREVENT OPENED EXCEL SOURCE FILE FROM SHOWING TO USER
Application.ScreenUpdating = False
'OPEN SOURCE EXCEL WORKBOOK IN "READ ONLY MODE"
Dim src As Workbook
Set src = Workbooks.Open(strSrc, True, True)
'GET THE TOTAL ROWS FROM THE SOURCE WORKBOOK
Dim iTotalRows As Integer
iTotalRows = src.Worksheets("PROJECT LIST").Range("A1:A" & src.Worksheets("PROJECT LIST").Cells(Rows.Count, "A").End(xlUp).Row).Rows.Count
'COPY DATA FROM SOURCE WORKBOOK -> DESTINATION WORKBOOK
Dim iCnt As Integer '(COUNTER)
For iCnt = 1 To iTotalRows
src.Worksheets("Test_File_8").Range("B" & (iCnt + 1)).Formula = src.Worksheets("PROJECT LIST").Range("A" & (iCnt + 1)).Formula
Next iCnt
'CLOSE THE SOURCE WORKBOOK FILE
src.Close False 'FALSE = DONT SAVE THE SOURCE FILE
Set src = Nothing 'FLUSH DATA
'ERROR FUNCTION
ErrHandler: Application.EnableEvents = True Application.ScreenUpdating = True End Sub
'MACRO TO READ-IN EXTERNAL EXCEL FILE FROM WHICH JOB NO.'S ARE EXTRACTED INTO USERFORM
I wonder whether someone can help me please.
I wanting to use this solution in a script I'm trying to put together, but I'm a little unsure about how to make a change which needs to be made.
You'll see in the solution that the file type which is opened is a Excel and indeed it's saved as such. But I the files I'd like to open and save are a mixture of .docx and .dat (Used by Dragon software) files.
Could someone possible tell me please is there a way by which I can amend the code so it opens and saves the files in file types other than Excel workbooks.
The reason behind this question because I'm currently using a script which creates a list of files in a Excel spreadsheet from a given folder. For each file that is retrieved there is a hyperlink, which I'd like to add fucntionality to which enables the user to copy the file and save it to a location of their choice.
To help this is the code which I use to create the list of files.
Public Sub ListFilesInFolder(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)
Dim LastRow As Long
Dim fName As String
On Error Resume Next
For Each FileItem In SourceFolder.Files
' display file properties
Cells(iRow, 3).Formula = iRow - 12
Cells(iRow, 4).Formula = FileItem.Name
Cells(iRow, 5).Formula = FileItem.Path
Cells(iRow, 6).Select
Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
FileItem.Path, TextToDisplay:="Click Here to Open"
iRow = iRow + 1 ' next row number
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
For Each Cell In Range("C13:F" & LastRow) ''change range accordingly
If Cell.Row Mod 2 = 1 Then ''highlights row 2,4,6 etc|= 0 highlights 1,3,5
Cell.Interior.Color = RGB(232, 232, 232) ''color to preference
Else
Cell.Interior.Color = RGB(141, 180, 226) 'color to preference or remove
End If
Next Cell
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Many thanks and kind regards
Chris
Miguel provided a fantastic solution which on initial testing appeared to work 100%. But as you will see from the comments at the end of the post there were some issues when the user cancelled the operation, so I made another post at this link where the problems were ironed out. Many thanks and kind regards. Chris
The code below shows how to retrieve the extension of a file, define an array with “allowed” extensions, and match the extension of the file to the array.
This is the outline for file manipulation, you'll just need to tailor it to you needs
Dim MinExtensionX
Dim Arr() As Variant
Dim lngLoc As Variant
'Retrieve extension of file
MinExtensionX = Mid(MyFile.Name, InStrRev(MyFile.Name, ".") + 1)
Arr = Array("xls", "xlsx", "docx", "dat") 'define which extensions you want to allow
On Error Resume Next
lngLoc = Application.WorksheetFunction.Match(MinExtensionX, Arr(), 0)
If Not IsEmpty(lngLoc) Then '
'check which kind of extension you are working with and create proper obj manipulation
If MinExtensionX = "docx" then
Set wApp = CreateObject("Word.Application")
wApp.DisplayAlerts = False
Set wDoc = wApp.Documents.Open (Filename:="C:\Documents\SomeWordTemplate.docx", ReadOnly:=True)
'DO STUFF if it's an authorized file. Then Save file.
With wDoc
.ActiveDocument.SaveAs Filename:="C:\Documents\NewWordDocumentFromTemplate.docx"
End With
wApp.DisplayAlerts = True
End if
End If
For files .Dat its a bit more complex, specially if you need to open/process data from the file, but this might help you out.
Edit:
2: Comments added
Hi IRHM,
I think you want something like this:
'Worksheet_FollowHyperlink' is an on click event that occurs every time you click on an Hyperlink within a Worksheet, You can find more here
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
'disable events so the user doesn't see the codes selection
Application.EnableEvents = False
Dim FSO
Dim sFile As String
Dim sDFolder As String
Dim thiswb As Workbook ', wb As Workbook
'Define workbooks so we don't lose scope while selecting sFile(thisworkbook = workbook were the code is located).
Set thiswb = thisworkbook
'Set wb = ActiveWorkbook ' This line was commented out because we no longer need to cope with 2 excel workbooks open at the same time.
'Target.Range.Value is the selection of the Hyperlink Path. Due to the address of the Hyperlink being "" we just assign the value to a
'temporary variable which is not used so the Click on event is still triggers
temp = Target.Range.Value
'Activate the wb, and attribute the File.Path located 1 column left of the Hyperlink/ActiveCell
thiswb.Activate
sFile = Cells(ActiveCell.Row, ActiveCell.Column - 1).Value
'Declare a variable as a FileDialog Object
Dim fldr As FileDialog
'Create a FileDialog object as a File Picker dialog box.
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
'Allow only single selection on Folders
fldr.AllowMultiSelect = False
'Show Folder picker dialog box to user and wait for user action
fldr.Show
'add the end slash of the path selected in the dialog box for the copy operation
sDFolder = fldr.SelectedItems(1) & "\"
'FSO System object to copy the file
Set FSO = CreateObject("Scripting.FileSystemObject")
' Copy File from (source = sFile), destination , (Overwrite True = replace file with the same name)
FSO.CopyFile (sFile), sDFolder, True
' check if there's multiple excel workbooks open and close workbook that is not needed
' section commented out because the Hyperlinks no longer Open the selected file
' If Not thiswb.Name = wb.Name Then
' wb.Close
' End If
Application.EnableEvents = True
End Sub
The above code Triggers when you click the Hyperlink and it promps a folder selection window.
You just need to paste the code into the Worksheet code. And you should be good to go.
I want to collect data from different files and insert it into a workbook doing something like this.
Do While THAT_DIFFERENT_FILE_SOMEWHERE_ON_MY_HDD.Cells(Rand, 1).Value <> "" And Rand < 65536
then 'I will search if the last row in my main worksheet is in this file...
End Loop
If the last row from my main worksheet is in the file, I'll quit the While Loop. If not, I'll copy everything. I'm having trouble finding the right algorithm for this.
My problem is that I don't know how to access different workbooks.
The best (and easiest) way to copy data from a workbook to another is to use the object model of Excel.
Option Explicit
Sub test()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xls", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set targetworkbook
Set wb2 = ActiveWorkbook
'For instance, copy data from a range in the first workbook to another range in the other workbook
wb2.Worksheets("Sheet2").Range("C3:D4").Value = wb.Worksheets("Sheet1").Range("A1:B2").Value
End Sub
You might like the function GetInfoFromClosedFile()
Edit: Since the above link does not seem to work anymore, I am adding alternate link 1 and alternate link 2 + code:
Private Function GetInfoFromClosedFile(ByVal wbPath As String, _
wbName As String, wsName As String, cellRef As String) As Variant
Dim arg As String
GetInfoFromClosedFile = ""
If Right(wbPath, 1) <> "" Then wbPath = wbPath & ""
If Dir(wbPath & "" & wbName) = "" Then Exit Function
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
On Error Resume Next
GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function
Are you looking for the syntax to open them:
Dim wkbk As Workbook
Set wkbk = Workbooks.Open("C:\MyDirectory\mysheet.xlsx")
Then, you can use wkbk.Sheets(1).Range("3:3") (or whatever you need)
There's very little reason not to open multiple workbooks in Excel. Key lines of code are:
Application.EnableEvents = False
Application.ScreenUpdating = False
...then you won't see anything whilst the code runs, and no code will run that is associated with the opening of the second workbook. Then there are...
Application.DisplayAlerts = False
Application.Calculation = xlManual
...so as to stop you getting pop-up messages associated with the content of the second file, and to avoid any slow re-calculations. Ensure you set back to True/xlAutomatic at end of your programming
If opening the second workbook is not going to cause performance issues, you may as well do it. In fact, having the second workbook open will make it very beneficial when attempting to debug your code if some of the secondary files do not conform to the expected format
Here is some expert guidance on using multiple Excel files that gives an overview of the different methods available for referencing data
An extension question would be how to cycle through multiple files contained in the same folder. You can use the Windows folder picker using:
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .Selected.Items.Count = 1 the InputFolder = .SelectedItems(1)
End With
FName = VBA.Dir(InputFolder)
Do While FName <> ""
'''Do function here
FName = VBA.Dir()
Loop
Hopefully some of the above will be of use
I had the same question but applying the provided solutions changed the file to write in. Once I selected the new excel file, I was also writing in that file and not in my original file. My solution for this issue is below:
Sub GetData()
Dim excelapp As Application
Dim source As Workbook
Dim srcSH1 As Worksheet
Dim sh As Worksheet
Dim path As String
Dim nmr As Long
Dim i As Long
nmr = 20
Set excelapp = New Application
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
.Show
path = .SelectedItems.Item(1)
End With
Set source = excelapp.Workbooks.Open(path)
Set srcSH1 = source.Worksheets("Sheet1")
Set sh = Sheets("Sheet1")
For i = 1 To nmr
sh.Cells(i, "A").Value = srcSH1.Cells(i, "A").Value
Next i
End Sub
With excelapp a new application will be called. The with block sets the path for the external file. Finally, I set the external Workbook with source and srcSH1 as a Worksheet within the external sheet.