I am currently using Application.GetOpenFilename with MultiSelect:=True to allow the user to select one or more files within a folder, then importing the data from all of the files into a worksheet. If multiple files are selected, the data from each file is appended to the data from the previous file until all of the selected files are imported.
I now have an instance where text files are stored in subfolders of a specific folder, with the subfolders created based on order numbers. I am now trying to define the parent folder as a variable, allow the user to input the subfolder name using Application.InputBox, then automatically import the data from all .txt files in the user-specified subfolder. I'm getting hung up with a Run-time error '53', File not found error. I know using the GetOpenFilename approach creates an array of the filenames, and I tried to replicate this by creating an array of the file names but I'm obviously missing something.
I'm basically trying to import all .txt files from something like the following:
C:\AOI_DATA64\SPC_DataLog\IspnDetails\ user defined subfolder \ *.txt
Code that works using Application.GetOpenFilename:
' Define that variables must be defined manually and will never be defined automatically
Option Explicit
' Hold specific variables in memory for use between sub-routines
Public DDThreshold As Variant
Public FileName As String
Public FilePath As String
Public OpenFileName As Variant
Public OrderNum As Variant
Public SaveWorkingDir As String
Public SecondsElapsed As Double
Public StartTime As Double
Public TimeRemaining As Double
Sub Import_DataFile()
' Add an error handler
' On Error GoTo ErrorHandler
' Speed up this sub-routine by turning off screen updating and auto calculating until the end of the sub-routine
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Define variable names and types
Dim DefaultOpenPath As String
Dim SaveWorkingDir As String
Dim OpenFileName As Variant
Dim WholeFile As String
Dim SplitArray
Dim LineNumber As Integer
Dim chkFormat1 As String
Dim i As Long
Dim n1 As Long
Dim n2 As Long
Dim fn As Integer
Dim RawData As String
Dim rngTarget As Range
Dim rngFileList As Range
Dim TargetRow As Long
Dim FileListRow As Long
Dim aLastRow As Long
Dim bLastRow As Long
Dim cLastRow As Long
Dim dLastRow As Long
Dim destCell As Range
' Set the default path to start at when importing a file
'On Error Resume Next
If Len(Dir("C:\AOI_DATA64\SPC_DataLog\IspnDetails", vbDirectory)) = 0 Then
DefaultOpenPath = "C:\"
Else
DefaultOpenPath = "C:\AOI_DATA64\SPC_DataLog\IspnDetails\"
End If
' When opening another file for processing, this section will save the previously opened file directory
'On Error Resume Next
If SaveWorkingDir = CurDir Then
ChDrive SaveWorkingDir
ChDir SaveWorkingDir
Else
ChDrive DefaultOpenPath
ChDir DefaultOpenPath
End If
' Select the source folder and point list file(s) to import into worksheet
'On Error GoTo ErrorHandler
OpenFileName = Application.GetOpenFilename( _
FileFilter:="AOI Inspection Results Data Files (*.txt), *.txt", _
Title:="Select a data file or files to import", _
MultiSelect:=True)
' Cancel the file import if the user exits the file import window or selects the Cancel button
If Not IsArray(OpenFileName) Then
MsgBox "" & vbNewLine & _
" No files were selected." & vbNewLine & _
"" & vbNewLine & _
" Import AOI Inspection Results Data Files was aborted.", vbInformation, "File Import Cancelled"
Exit Sub
End If
' Clear contents and reset formatting of cells in all worksheets
aLastRow = Worksheets("AOI Inspection Summary").Cells(Rows.Count, "B").End(xlDown).Row
bLastRow = Worksheets("Raw Data").Cells(Rows.Count, "A").End(xlDown).Row
cLastRow = Worksheets("Parsed Data").Cells(Rows.Count, "A").End(xlDown).Row
Worksheets("AOI Inspection Summary").Range("E6:L14").ClearContents
If aLastRow > 0 Then
Worksheets("AOI Inspection Summary").Range("B24:L" & aLastRow).ClearContents
Worksheets("AOI Inspection Summary").Range("B24:L" & aLastRow).ClearFormats
End If
If bLastRow > 0 Then
Worksheets("Raw Data").Range("A1:Q" & bLastRow).ClearContents
Worksheets("Raw Data").Range("A1:Q" & bLastRow).ClearFormats
End If
If cLastRow > 0 Then
Worksheets("Parsed Data").Range("A1:Q" & cLastRow).ClearContents
Worksheets("Parsed Data").Range("A1:Q" & cLastRow).ClearFormats
End If
Worksheets("AOI Inspection Summary").Range("E6:L9").NumberFormat = "#" 'Format cells to Text
Worksheets("AOI Inspection Summary").Range("E10:L13").NumberFormat = "#,000" 'Format Cells to Number with commas
Worksheets("AOI Inspection Summary").Range("E14:L14").NumberFormat = "0.00%" 'Format cells to Percent
Worksheets("Raw Data").Columns("A:Z").EntireColumn.ColumnWidth = 8.09
Worksheets("Parsed Data").Columns("A:Z").EntireColumn.ColumnWidth = 8.09
' Update "Defect Density Threshold" to default value unless user entered a new value
If DDThreshold > 0 Then
Worksheets("AOI Inspection Summary").Range("E10").Value = DDThreshold
Else
Worksheets("AOI Inspection Summary").Range("E10").Value = "3,000,000"
End If
' Save the user selected open file directory as the default open file path while the worksheet is open
SaveWorkingDir = CurDir
' Timer Start (calculate the length of time this sub-routine takes to complete after selecting file(s) to import)
StartTime = Timer
' Check selected input file format for YesTech AOI Inspection Results format
Const chkYesTech = "[StartIspn]"
For n1 = LBound(OpenFileName) To UBound(OpenFileName)
fn = FreeFile
Open OpenFileName(n1) For Input As #fn
Application.StatusBar = "Processing ... " & OpenFileName(n1)
WholeFile = Input(LOF(fn), #fn)
SplitArray = Split(WholeFile, vbCrLf)
LineNumber = 1
chkFormat1 = SplitArray(LineNumber - 1)
Close #fn
If InStr(1, chkFormat1, chkYesTech, vbBinaryCompare) > 0 Then
MsgBox OpenFileName(n1) & vbNewLine & " has been verified as a YesTech AOI Inspection Results Data File"
' Import user selected YesTech AOI Inspection Results Data File(s) to "Raw Data" worksheet
Application.DisplayAlerts = False
TargetRow = 0
Set destCell = Worksheets("Raw Data").Range("B1")
For n2 = LBound(OpenFileName) To UBound(OpenFileName)
fn = FreeFile
Open OpenFileName(n2) For Input As #fn
Application.StatusBar = "Processing ... " & OpenFileName(n2)
' Import data from file into Raw Data worksheet
Do While Not EOF(fn)
Line Input #fn, RawData
If Len(Trim(RawData)) > 0 Then
TargetRow = TargetRow + 1
Worksheets("Raw Data").Range("B" & TargetRow) = RawData
End If
Loop
Next n2
Close #fn
Set rngTarget = Worksheets("Raw Data").Range("B1" & ":" & Worksheets("Raw Data").Range("B1").End(xlDown).Address)
With rngTarget
.TextToColumns Destination:=destCell, DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=True, Space:=False, Other:=False, OtherChar:="|", _
FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
End With
Application.DisplayAlerts = True
Else: MsgBox OpenFileName(n1) & vbNewLine & " is not a YesTech AOI Inspection Results Data File."
Exit Sub
End If
Next
' Create a number list (autofill) in Col A to maintain original import sort order
dLastRow = Worksheets("Raw Data").Cells(Rows.Count, "B").End(xlUp).Row
Worksheets("Raw Data").Range("A1:A" & dLastRow).Font.Color = RGB(200, 200, 200)
Worksheets("Raw Data").Range("A1") = "1"
Worksheets("Raw Data").Range("A2") = "2"
Worksheets("Raw Data").Range("A1:A2").AutoFill Destination:=Worksheets("Raw Data").Range("A1:A" & dLastRow), Type:=xlFillDefault
Worksheets("Raw Data").Range("F1:Q" & dLastRow).NumberFormat = "0.0"
' List open file name(s) on spreadsheet for user reference
Worksheets("AOI Inspection Summary").Range("E9").Font.Name = "Calibri"
Worksheets("AOI Inspection Summary").Range("E9").Font.Size = 9
Worksheets("AOI Inspection Summary").Range("E9").Font.Bold = False
Worksheets("AOI Inspection Summary").Range("E9").Font.Color = RGB(0, 0, 255)
FileListRow = 0
Set rngFileList = Worksheets("AOI Inspection Summary").Range("E9")
For i = LBound(OpenFileName) To UBound(OpenFileName)
' Add imported file name hyperlink to imported files in list of imported files
' rngFileList.Offset(FileListRow, 0) = OpenFileName(i)
rngFileList.Hyperlinks.Add Anchor:=rngFileList, _
Address:=OpenFileName(i), _
ScreenTip:="Imported File Number " & FileListRow + 1, _
TextToDisplay:=OpenFileName(i)
Worksheets("AOI Inspection Summary").Range("E7").Value = OpenFileName(i)
FileListRow = FileListRow + 1
Next i
' Auto fit the width of columns for RAW Data
Worksheets("Raw Data").Columns("A:Z").EntireColumn.AutoFit
' Timer Stop (calculate the length of time this sub-routine took to complete)
SecondsElapsed = Round(Timer - StartTime, 2)
' Turn screen updating and auto calculating back on since file processing is now complete
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
' Display a message to report the sub-routine processing time after file selection including the number of data rows that have been imported
MsgBox "AOI Inspection Results processed and imported in " & SecondsElapsed & " seconds" & " ." & vbNewLine & _
" Successfully imported " & (TargetRow) & " rows of data.", vbInformation, "Data Import Results"
' Reset to defaults in the event of a processing error during the sub-routine execution
ErrorHandler:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Err.Number <> 0 Then
' Display a message to user including error code in the event of an error during execution
MsgBox "An error number " & Err.Number & " was encountered!" & vbNewLine & _
"Part or all of this VBA script was not completed.", vbInformation, "Error Message"
End If
Call Create_Report
End Sub
And here's my attempt at defining the parent folder, asking the user for the subfolder name using Application.InputBox, and loading all of the *.txt filenames into an array to be imported:
' Define that variables must be defined manually and will never be defined automatically
Option Explicit
' Hold specific variables in memory for use between sub-routines
Public DDThreshold As Variant
Public FileName As String
Public FilePath As String
Public OpenFileName As Variant
Public OrderNum As Variant
Public SaveWorkingDir As String
Public SecondsElapsed As Double
Public StartTime As Double
Public TimeRemaining As Double
Sub OrderLineNum()
' Add an error handler
'On Error GoTo ErrorHandler
' Speed up sub-routine by turning off screen updating and auto calculating
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Define variable names and data types
Dim DefaultOpenPath As String
Dim SaveWorkingDir As String
Dim OrderNum As Variant
Dim GetFile As String
Dim FileCount As Long
Dim OpenFileName() As String
ReDim OpenFileName(1000)
Dim WholeFile As String
Dim SplitArray
Dim LineNumber As Integer
Dim chkFormat1 As String
Dim i As Long
Dim n1 As Long
Dim n2 As Long
Dim fn As Integer
Dim RawData As String
Dim rngTarget As Range
Dim rngFileList As Range
Dim TargetRow As Long
Dim FileListRow As Long
Dim aLastRow As Long
Dim bLastRow As Long
Dim cLastRow As Long
Dim dLastRow As Long
Dim destCell As Range
' Set the default path to start at when importing a file
' On Error Resume Next
If Len(Dir("C:\AOI_DATA64\SPC_DataLog\IspnDetails", vbDirectory)) = 0 Then
DefaultOpenPath = "C:\"
Else
DefaultOpenPath = "C:\AOI_DATA64\SPC_DataLog\IspnDetails\"
End If
' When opening another file for processing, save the previously opened file directory
' On Error Resume Next
If SaveWorkingDir = CurDir Then
ChDrive SaveWorkingDir
ChDir SaveWorkingDir
Else
ChDrive DefaultOpenPath
ChDir DefaultOpenPath
End If
' Open InputBox to get order-line number from user
OrderNum = Application.InputBox(prompt:= _
"Enter Order-Line Number (e.g. 12345678-9)", _
Title:="Password Required for This Function", _
Default:="", _
Left:=25, _
Top:=25, _
HelpFile:="", _
HelpContextID:="", _
Type:=2)
If OrderNum = "" Then
MsgBox "No Order Number entered. No data will be imported.", vbInformation, "Invalid Order Number"
Exit Sub
ElseIf OrderNum = "0" Then
MsgBox "Order Number cannot be 0. No data will be imported.", vbInformation, "Invalid Order Number"
Exit Sub
ElseIf OrderNum = False Then
MsgBox "User cancelled. No data will be imported.", vbInformation, "User Cancelled"
Exit Sub
End If
' Create an array of filenames found in the Order-Line Number sub-folder
GetFile = Dir$(CurDir & "\" & OrderNum & "\" & "*.txt")
Do While GetFile <> ""
OpenFileName(FileCount) = GetFile
GetFile = Dir$
FileCount = FileCount + 1
Loop
ReDim Preserve OpenFileName(FileCount - 1)
' Save the user selected open file directory as the default open file path while the worksheet is open
SaveWorkingDir = CurDir
' Timer Start (calculate the length of time this sub-routine takes to complete after selecting file(s) to import)
StartTime = Timer
' Cancel the file import if the Order-Line Number subfolder doesn't exist
If Not IsArray(OpenFileName) Then
MsgBox "" & vbNewLine & _
" No files were selected." & vbNewLine & _
"" & vbNewLine & _
" Import AOI Inspection Results Data Files was aborted.", vbInformation, "File Import Cancelled"
Exit Sub
End If
' Clear contents of cells and data worksheets
aLastRow = Worksheets("AOI Inspection Summary").Cells(Rows.Count, "B").End(xlDown).Row
bLastRow = Worksheets("Raw Data").Cells(Rows.Count, "A").End(xlDown).Row
cLastRow = Worksheets("Parsed Data").Cells(Rows.Count, "A").End(xlDown).Row
Worksheets("AOI Inspection Summary").Range("E6:L14").ClearContents
If aLastRow > 0 Then
Worksheets("AOI Inspection Summary").Range("B24:L" & aLastRow).ClearContents
Worksheets("AOI Inspection Summary").Range("B24:L" & aLastRow).ClearFormats
End If
If bLastRow > 0 Then
Worksheets("Raw Data").Range("A1:Q" & bLastRow).ClearContents
Worksheets("Raw Data").Range("A1:Q" & bLastRow).ClearFormats
End If
If cLastRow > 0 Then
Worksheets("Parsed Data").Range("A1:Q" & cLastRow).ClearContents
Worksheets("Parsed Data").Range("A1:Q" & cLastRow).ClearFormats
End If
' Update "Defect Density Threshold" to default value unless user entered a new value
If DDThreshold > 0 Then
Worksheets("AOI Inspection Summary").Range("E10").Value = DDThreshold
Else
Worksheets("AOI Inspection Summary").Range("E10").Value = "3,000,000"
End If
'Check selected input file format for YesTech AOI Inspection Results format
Const chkYesTech = "[StartIspn]"
For n1 = LBound(OpenFileName) To UBound(OpenFileName)
fn = FreeFile
Open OpenFileName(n1) For Input As #fn
Application.StatusBar = "Processing ... " & OpenFileName(n1)
WholeFile = Input(LOF(fn), #fn)
SplitArray = Split(WholeFile, vbCrLf)
LineNumber = 1
chkFormat1 = SplitArray(LineNumber - 1)
Close #fn
If InStr(1, chkFormat1, chkYesTech, vbBinaryCompare) > 0 Then
MsgBox OpenFileName(n1) & vbNewLine & " has been verified as a YesTech AOI Inspection Results Data File"
' Import user selected YesTech AOI Inspection Results Data File(s) to "Raw Data" worksheet
TargetRow = 0
Set destCell = Worksheets("Raw Data").Range("B1")
For n2 = LBound(OpenFileName) To UBound(OpenFileName)
fn = FreeFile
Open OpenFileName(n2) For Input As #fn
Application.StatusBar = "Processing ... " & OpenFileName(n2)
Do While Not EOF(fn)
Line Input #fn, RawData
If Len(Trim(RawData)) > 0 Then
TargetRow = TargetRow + 1
Worksheets("Raw Data").Range("B" & TargetRow) = RawData
End If
Loop
Next n2
Close #fn
Set rngTarget = Worksheets("Raw Data").Range("B1" & ":" & Worksheets("Raw Data").Range("B1").End(xlDown).Address)
With rngTarget
.TextToColumns Destination:=destCell, DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=True, Space:=False, Other:=False, OtherChar:="|", _
FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
End With
Else: MsgBox OpenFileName(n1) & vbNewLine & " is not a YesTech AOI Inspection Results Data File."
Exit Sub
End If
Next
' Create a number list (autofill) in Col A to maintain original import sort order
dLastRow = Worksheets("Raw Data").Cells(Rows.Count, "B").End(xlUp).Row
Worksheets("Raw Data").Range("A1:A" & dLastRow).Font.Color = RGB(200, 200, 200)
Worksheets("Raw Data").Range("A1") = "1"
Worksheets("Raw Data").Range("A2") = "2"
Worksheets("Raw Data").Range("A1:A2").AutoFill Destination:=Worksheets("Raw Data").Range("A1:A" & dLastRow), Type:=xlFillDefault
Worksheets("Raw Data").Range("F1:Q" & dLastRow).NumberFormat = "0.0"
' List open file name(s) on spreadsheet for user reference
Worksheets("AOI Inspection Summary").Range("E9").Font.Name = "Calibri"
Worksheets("AOI Inspection Summary").Range("E9").Font.Size = 9
Worksheets("AOI Inspection Summary").Range("E9").Font.Bold = True
Worksheets("AOI Inspection Summary").Range("E9").Font.Color = RGB(0, 0, 255)
FileListRow = 0
Set rngFileList = Worksheets("AOI Inspection Summary").Range("E9")
For i = LBound(OpenFileName) To UBound(OpenFileName)
Debug.Print OpenFileName(i)
' Add imported file name or hyperlink to imported files in list of imported files
' rngFileList.Offset(FileListRow, 0) = OpenFileName(i)
rngFileList.Offset(FileListRow, 0).Hyperlinks.Add Anchor:=rngFileList.Offset(FileListRow, 0), _
Address:=OpenFileName(i), _
ScreenTip:="Imported File Number " & FileListRow + 1, _
TextToDisplay:=OpenFileName(i)
rngFileList.Offset(FileListRow, 0).Font.Name = "Calibri"
rngFileList.Offset(FileListRow, 0).Font.Size = 9
rngFileList.Offset(FileListRow, 0).Font.Color = RGB(0, 0, 255)
FileListRow = FileListRow + 1
Next i
' Auto fit the width of columns for RAW Data
Worksheets("Raw Data").Columns("A:Z").EntireColumn.AutoFit
' Timer Stop (calculate the length of time this sub-routine took to complete)
SecondsElapsed = Round(Timer - StartTime, 2)
' Turn screen updating and auto calculating back on since file processing is now complete
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
' Display a message to report the sub-routine processing time after file selection including the number of data rows that have been imported
MsgBox "AOI Inspection Results processed and imported in " & SecondsElapsed & " seconds" & " ." & vbNewLine & _
" Successfully imported " & (TargetRow) & " rows of data.", vbInformation, "Data Import Results"
' Reset to defaults in the event of a processing error during the sub-routine execution
ErrorHandler:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Err.Number <> 0 Then
' Display a message to user including error code in the event of an error during execution
MsgBox "An error number " & Err.Number & " was encountered!" & vbNewLine & _
"Part or all of this VBA script was not completed.", vbInformation, "Error Message"
End If
End Sub
Any ideas or suggestions for a better approach would be greatly appreciated.
As mentioned in my comment, there's a lot going on in your post. However, focusing on this
I am now trying to define the parent folder as a variable, allow the user to input the subfolder name using Application.InputBox, then automatically import the data from all .txt files in the user-specified subfolder.
I have a solution - you can create an array that stores each file (both the path and file name), which you should be able to use to get the file names and then do whatever you need:
Sub import_files()
Dim files As String
Dim parentDir As String
parentDir = InputBox("Please input the directory you want to import files from")
If parentDir = "" Then Exit Sub 'If they hit "Cancel" or don't put anything.
' parentDir = GetFolder() 'UNCOMMENT THIS if you want the user to select a folder via "Windows Explorer"
files = LoopThroughFiles(parentDir, "txt")
' Debug.Print (files)
Dim iFiles() As String
iFiles() = Split(files, ",")
Dim i As Long
For i = LBound(iFiles) To UBound(iFiles)
If iFiles(i) <> "" Then
Debug.Print ("File located: " + parentDir + "\" + iFiles(i))
' THIS IS YOUR ARRAY, `iFILES`, SO HERE IS WHERE YOU DO STUFF
End If
Next i
End Sub
Private Function LoopThroughFiles(inputDirectoryToScanForFile, filenameCriteria) As String
'https://stackoverflow.com/a/45749626/4650297
Dim tmpOut As String
Dim StrFile As String
'Debug.Print "in LoopThroughFiles. inputDirectoryToScanForFile: ", inputDirectoryToScanForFile
StrFile = Dir(inputDirectoryToScanForFile & "\*" & filenameCriteria)
Do While Len(StrFile) > 0
' Debug.Print StrFile
tmpOut = tmpOut + "," + StrFile
StrFile = Dir
Loop
LoopThroughFiles = tmpOut
End Function
Function GetFolder() As String
' https://stackoverflow.com/a/26392703/4650297
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Edit: I added a method to have the user select the folder via a more "traditional" Windows Explorer type window, instead of pasting in a path string. Either one should work for you though, let me know any questions.
Related
I have between 800 excels files that I need to transfer over to one sheet but before the transfer, I need to add a column ("A:A") and copy one cell value (before column added ("C1") after column ("D1")) and use column ("C:C") to get the range it would need to be pasted in column("A:A")
I have done the code already but struggling to add this on. If anyone can help that would be amazing.
Sub LoopThrough()
Dim MyFile As String, Str As String, MyDir As String
Dim sh As Worksheet, MasterRange As Range, TempWB As Workbook, TempSH As Worksheet, TempRng As Range, TempRow As Range
Dim NewMasterLine As Long
Dim StartTime As Double
Dim MinutesElapsed As String
StartTime = Timer
On Error GoTo ErrorHandler
Set sh = ThisWorkbook.Worksheets("Sheet1")
' Change address to suite
MyDir = "C:\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
' The following lines will put excel in a state similar to "frozen" mode. This will increase the code performance, as CPU will solely focus on performing
' the operations required by the code and not on showing the changes happening on excel
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim x As Long
x = 0
' Here starts the loop related to the files in folder
Do While MyFile <> ""
'TempWB is a Worksheet object - will be the importing worksheet. TempRng is the used range in sheet 1 of the workbook
Set TempWB = Workbooks.Open(FileName:=MyFile, UpdateLinks:=False, Password:=CalcPassword(MyFile))
Columns(1).Insert
Range("c2").Copy Range("A4:A10000")
Set TempSH = TempWB.Worksheets(1)
Set TempRng = TempSH.Range("A1:DB" & TempSH.Range("A" & TempSH.Rows.Count).End(xlUp).Row)
TempRng.Range("A:A").Insert ' This is where I tried to add in the extra column
TempRng.Range("A1").Value = TempRng.Range("D1").Value ' Tried doing this as a test but still pasted as if no changes had been made????
'NewMasterLine is the last used row (+1) of the Master Workbook (It is basically where the new rows will start to be imported)
NewMasterLine = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
If NewMasterLine > 1 Then NewMasterLine = NewMasterLine + 1
'This will loop through all the rows of the range to be imported, checking the first column.
' If the value in the second column is work-xne-ams, will import the single row in the master workbook
For Each TempRow In TempRng.Rows
If Left(TempRow.Cells(1, 2).Value, 5) = "SHIFT" Or TempRow.Row < 4 Then
'If TempRow.Cells(1, 2).Value = "SHIFT--1" Or TempRow.Row < 4 Then
Set MasterRange = sh.Range("A" & NewMasterLine & ":DA" & NewMasterLine)
MasterRange.Value = TempRow.Value
NewMasterLine = NewMasterLine + 1
End If
Next
TempWB.Close savechanges:=False
MyFile = Dir()
x = x + 1
ThisWorkbook.Worksheets("PWD").Range("H2") = x
Loop
ErrorHandler:
If Err.Number <> 0 Then MsgBox "An error occurred." & vbNewLine & vbNewLine & "Last file that was attempted to be opened: " & MyFile & vbNewLine & vbNewLine & Err.Description
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation
End Sub
Function CalcPassword(FileName As String) As String
CalcPassword = ""
On Error Resume Next
Dim TheFile As String: TheFile = Split(Split(FileName, "\")(UBound(Split(FileName, "\"))), ".")(0)
Dim PWD As Range: Set PWD = ThisWorkbook.Worksheets("PWD").ListObjects("PWD").DataBodyRange
CalcPassword = WorksheetFunction.VLookup(TheFile, PWD, 5, False)
End Function
I have the following code to copy images from one workbook to another. The code opens the source workbook/sheet, copies the image then closes the workbook. This process repeats multiple times. Is there a more efficient way to do this? maybe bypassing the clipboard?
I only need to copy 1 image(named "Picture 4") and 2-3 cell values per source workbook/sheet. I have 7-8 source workbook.
Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS1.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")
srcWS.Pictures(4).Copy
dstWS.Range("B7").PasteSpecial
Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS2.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")
srcWS.Pictures(4).Copy
dstWS.Range("G8").PasteSpecial
So the fast solution is here:
Turn off Screen Updating and then turn it on again afterwards, I implemented some time measurement in my code to visualize this:
Option Explicit
Sub copy_images_original()
Dim dstWS As Worksheet
Set dstWS = ThisWorkbook.Sheets(1)
Dim srcWB As Workbook
Dim srcWS As Worksheet
Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS1.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")
srcWS.Pictures(4).Copy
dstWS.Range("B7").PasteSpecial
srcWB.Close
Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS2.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")
srcWS.Pictures(4).Copy
dstWS.Range("G8").PasteSpecial
srcWB.Close
End Sub
Sub CalculateRunTime_Seconds()
'PURPOSE: Determine how many seconds it took for code to completely run
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim StartTime As Double
Dim SecondsElapsed As Double
'Remember time when macro starts
StartTime = Timer
'*****************************
Call turn_app_off
Call copy_images_original
Call turn_app_on
'*****************************
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
Sub turn_app_off()
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
End Sub
Sub turn_app_on()
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
What has now improved?
Your srcWBs will now be closed, your original source code didnt do that.
In my scenario here, the execution time improved from 2 Secs to 1,4 Secs.
So your Code runs 25% faster without much effort.
Hope you find my suggestion fair enough.
With best regards
Create a Report
I was assuming that the destination workbook and the workbook containing this code, ThisWorkbook, are the same.
Adjust the values in the constants section.
Run only the createReport procedure. The function getFilePathsInFolder is being called by it.
Since ThisWorkbook will not have an "xlsx" extension, the statement If StrComp(FilePaths(fp), dstFilePath, vbTextCompare) <> 0 Then is redundant, but I'm leaving it because you might one day change the file extension to "xls*" when the code could do some damage.
Abstract
It will look in the specified folder and write all .xlsx files to an array. It will loop through the array and open each workbook to copy the picture, specified by its index, and paste it and write the specified cell values, to the specified locations of the destination workbook, closing each source workbook afterwards.
The Code
Option Explicit
Sub createReport()
Const ProcName As String = "createReport"
On Error GoTo clearError
' Source
Const Extension As String = "xlsx"
Const srcName As String = "sheetwithimage"
Const srcList As String = "A1,A2,A3" ' add more
Const picIndex As Long = 1
' Destination
Const dstName As String = "Sheet1"
Const dstList As String = "B1,B2,B3" ' add more
Const picAddress As String = "B7"
Const colOffset As Long = 5
' Write file paths from Source Folder Path to File Paths array.
Dim wbDst As Workbook: Set wbDst = ThisWorkbook
Dim srcFolderPath As String: srcFolderPath = wbDst.Path
Dim FilePaths As Variant
FilePaths = getFilePathsInFolder(srcFolderPath, Extension)
Dim srcCells() As String: srcCells = Split(srcList, ",")
Dim dstCells() As String: dstCells = Split(dstList, ",")
' Use a variable for lower and upper if inside another loop.
' Split ensures that lower is 0, so no need for lower variable.
Dim CellsUB As Long: CellsUB = UBound(srcCells) ' or 'Ubound(dstCells)'
Dim dst As Worksheet: Set dst = wbDst.Worksheets(dstName)
Dim dstFilePath As String: dstFilePath = wbDst.FullName
' Declare new variables occurring in the following loop.
Dim wbSrc As Workbook
Dim src As Worksheet
Dim srcCount As Long
Dim fp As Long
Dim n As Long
Application.ScreenUpdating = False
' We don't care if 'FilePaths' is zero, one or five-based, since we
' cannot use fp because of 'ThisWorkbook'; hence 'srcCount'.
For fp = LBound(FilePaths) To UBound(FilePaths)
' We have to skip 'ThisWorkbook'. Using 'StrComp' with 'vbTextCompare'
' is a great way for comparing strings case-insensitively i.e. 'A=a'.
' '0' means it is a match.
If StrComp(FilePaths(fp), dstFilePath, vbTextCompare) <> 0 Then
Set wbSrc = Workbooks.Open(FilePaths(fp), True, True)
Set src = wbSrc.Worksheets(srcName)
src.Pictures(picIndex).Copy
dst.Range(picAddress).Offset(, srcCount * colOffset).PasteSpecial
For n = 0 To CellsUB ' 'Split'
dst.Range(dstCells(n)).Offset(, srcCount * colOffset).Value _
= src.Range(srcCells(n)).Value
Next n
wbSrc.Close SaveChanges:=False
srcCount = srcCount + 1
End If
Next fp
' Save and/or inform user.
If srcCount > 0 Then
dst.Range("A1").Select
wbDst.Save
Application.ScreenUpdating = True
If srcCount = 1 Then
MsgBox "Data from 1 workbook transferred.", vbInformation, "Success"
Else
MsgBox "Data from " & srcCount & " workbooks transferred.", _
vbInformation, "Success"
End If
Else
MsgBox "No matching workbooks found in folder '" & srcFolderPath _
& "'!", vbCritical, "Fail"
End If
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub
Function getFilePathsInFolder( _
FolderPath As String, _
Optional ByVal ExtensionPattern As String = "", _
Optional ByVal FirstIndex As Long = 0) _
As Variant
Const ProcName As String = "listFilePathsInFolder"
On Error GoTo clearError
With CreateObject("Scripting.FileSystemObject")
Dim fsoFolder As Object
Set fsoFolder = .GetFolder(FolderPath)
Dim FilesCount As Long
FilesCount = fsoFolder.Files.Count
If FilesCount > 0 Then
Dim n As Long
n = FirstIndex - 1
Dim OneD As Variant
ReDim OneD(FirstIndex To FilesCount + n)
Dim fsoFile As Object
If ExtensionPattern = "" Then
For Each fsoFile In fsoFolder.Files
n = n + 1
OneD(n) = fsoFile.Path
Next fsoFile
getFilePathsInFolder = OneD
Else
For Each fsoFile In fsoFolder.Files
If LCase(.GetExtensionName(fsoFile)) _
Like LCase(ExtensionPattern) Then
n = n + 1
OneD(n) = fsoFile.Path
End If
Next fsoFile
If n > FirstIndex - 1 Then
ReDim Preserve OneD(FirstIndex To n)
getFilePathsInFolder = OneD
Else
Debug.Print "'" & ProcName & "': " _
& "No '" & ExtensionPattern & "'-files found."
End If
End If
Else
Debug.Print "'" & ProcName & "': " _
& "No files found."
End If
End With
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': Unexpected error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
Please find the VBA code below:
Sub Select_File_Or_Files_Mac()
Dim MyPath As String
Dim MyScript As String
Dim MyFiles As String
Dim MySplit() As String
Dim a As String
Dim mybook As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim LastCell2 As Range
Dim cell As Variant
Dim Column As Integer
Dim rowno As Integer
On Error GoTo ErrHandler:
MyPath = MacScript("return (path to documents folder) as String")
'Or use MyPath = "Macintosh HD:Users:Ron:Desktop:TestFolder:"
' In the following statement, change true to false in the line "multiple
' selections allowed true" if you do not want to be able to select more
' than one file. Additionally, if you want to filter for multiple files, change
' {""com.microsoft.Excel.xls""} to
' {""com.microsoft.excel.xls"",""public.comma-separated-values-text""}
' if you want to filter on xls and csv files, for example.
MyScript = _
"set applescript's text item delimiters to "","" " & vbNewLine & _
"set theFiles to (choose file of type " & _
" {""org.openxmlformats.spreadsheetml.sheet.macroenabled""} " & _
"with prompt ""Please select a file or files"" default location alias """ & _
MyPath & """ multiple selections allowed true) as string" & vbNewLine & _
"set applescript's text item delimiters to """" " & vbNewLine & _
"return theFiles"
MyFiles = MacScript(MyScript)
MsgBox MyFiles
'On Error GoTo 0
MySplit = Split(MyFiles, ":")
MsgBox MySplit
'For N = LBound(MySplit) To UBound(MySplit)
a = MySplit(UBound(MySplit()))
MsgBox a
' Get the fi le name only and test to see if it is open.
'Fname = Right(MySplit(N), Len(MySplit(N)) - InStrRev(MySplit(N), Application.PathSeparator, , 1))
'If bIsBookOpen(Fname) = False Then
'MsgBox MySplit
'Set mybook = Nothing
'On Error Resume Next
Set mybook = Workbooks.Open(a)
Set ws1 = ThisWorkbook.Worksheets("User_Financial_Input")
Set ws2 = mybook.Worksheets("User_Financial_Input")
ws2.Activate
With ws2
Set LastCell2 = ws2.Range("InputCells_User_Financial_Input")
MsgBox LastCell2
End With
ws2.Select
ws1.Activate
For Each cell In LastCell2
Column = cell.Column
rowno = cell.Row
ws1.Cells(rowno, Column) = cell.value
Next
ErrHandler:
If Err.Number = 9 Then
Answer = MsgBox(Err.Description & Err.Number, vbCritical, "Error")
ElseIf Err.Number = 1004 Then
Answer = MsgBox(Err.Description & Err.Number, vbCritical, "Error")
ElseIf Err.Number = 0 Then
Else
Answer = MsgBox(Err.Description & Err.Number, vbCritical, "Error")
End If
End Sub
There is some problem in the line Set mybook = Workbooks.Open(a). I am getting "Type 13" mismatch error.
The following code opens selected files, one at a time; if a file contains specific text string in B11 (there are four variation: LS2A, LS1PRA, LS1A and LSM12), specified data from Sheet(1) of each file is copied into an array. The search is performed by function “SearchFor” that is called in the main routine.
The array ArrCopy is filled with data from each file and should output into one of the four sheets in Master Workbook(SABI, SABII,LSM or LPRI&II). The output sheet is determined by the text string in B11 of each file.
I can’t get data to output to Master workbook for some reason. I've tried Debug.Print each array item after it's filled and I can see that the array is filled with correct data but I can't get the values to tranfer to the master workbook. The code runs but nothing is outputed on the worksheet.
Please suggest how to make this work. Thanks
Option Explicit
Function SearchFor(output As Worksheet)
Dim rowsCount As Long
Dim NCBead1 As Long, NCBead2 As Long, PCBead1 As Long, PCBead2 As Long
Dim IniString As String, IniVar As String
Dim rngCell As Range, rngCell2 As Range
Dim ArrCopy(1 To 9) As Variant
Dim LastRow As Long
Dim aCell As Range
LastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
'extract initial after last underscore
IniString = ActiveWorkbook.Sheets(1).Range("B6").Value
IniVar = Right(IniString, Len(IniString) - InStrRev(IniString, "_", , 1))
Debug.Print IniVar
'Debug.Print "LastRow = " & LastRow
Set aCell = ActiveSheet.Range("B1:B" & LastRow).Find(What:="Trimmed Mean", LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'Debug.Print "Trimmed Mean can be found in Row # " & aCell.Row
'wb.Sheets(1).Select
For Each rngCell In ActiveSheet.Range("B" & aCell.Row & ":B" & LastRow)
If InStr(rngCell, "NC") > 0 Then
Debug.Print rngCell.Row
NCBead1 = rngCell.Offset(0, 1).Value
NCBead2 = rngCell.Offset(0, 2).Value
'End If
Exit For
End If
Next rngCell
For Each rngCell2 In ActiveSheet.Range("B" & aCell.Row & ":B" & LastRow)
If InStr(rngCell2, "PC") > 0 Then
Debug.Print rngCell2.Row
PCBead1 = rngCell2.Offset(0, 1).Value
PCBead2 = rngCell2.Offset(0, 2).Value
'End If
Exit For
End If
Next rngCell2
'Next searched
Debug.Print NCBead2
ArrCopy(1) = ActiveSheet.Range("B3").Value
ArrCopy(2) = IniVar
ArrCopy(3) = NCBead1
ArrCopy(4) = NCBead2
ArrCopy(5) = PCBead1
ArrCopy(6) = PCBead2
ArrCopy(7) = ActiveSheet.Range("B6").Value
ArrCopy(8) = NCBead1
ArrCopy(9) = NCBead1
' one row spanning several columns
Debug.Print "ArrCopy" & ArrCopy(1)
Debug.Print "ArrCopy" & ArrCopy(2)
Debug.Print "ArrCopy" & ArrCopy(3)
Dim Destination As Range
Set Destination = output.Range("A" & output.Range("A" & Rows.Count).End(xlUp).Row + 1)
Set Destination = Destination.Resize(1, UBound(ArrCopy))
Destination.Value = ArrCopy
End Function
Sub openselectedfiles()
Dim SaveDriveDir As String, MyPath As String, FnameInLoop As String
Dim mybook As Workbook, thisWb As Workbook
Dim N As Long, LstUnderSc As Long, ExtPer As Long, Varin As Long
Dim Fname As Variant, ArrCopy(1 To 9) As Variant
Dim output As Worksheet
Dim inLS2A As Boolean, inLS1PRA As Boolean, inLS1A As Boolean, inLSM12 As Boolean
Set thisWb = ThisWorkbook
' Save the current directory.
SaveDriveDir = CurDir
' Set the path to the folder that you want to open.
MyPath = Application.DefaultFilePath
' Change drive/directory to MyPath.
ChDrive MyPath
ChDir MyPath
' Open GetOpenFilename with the file filters.
Fname = Application.GetOpenFilename( _
FileFilter:="CSV Files (*.csv),*.csv", _
Title:="Select a file or files", _
MultiSelect:=True)
' Perform some action with the files you selected.
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
If bIsBookOpen(FnameInLoop) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(Fname(N))
On Error GoTo 0
If Not mybook Is Nothing Then
mybook.Sheets(1).Select
With ActiveSheet.Range("B11")
inLS2A = InStr(1, .Value, "LS2A", 1) > 0
inLS1PRA = InStr(1, .Value, "LS1PRA", 1) > 0
inLS1A = InStr(1, .Value, "LS1A", 1) > 0
inLSM12 = InStr(1, .Value, "LSM12", 1) > 0
End With
If inLS2A Then
Set output = thisWb.Sheets("SABII")
SearchFor output
ElseIf inLS1PRA Then
Set output = thisWb.Sheets("LPRI&II")
SearchFor output
ElseIf inLS1A Then
Set output = thisWb.Sheets("sabI")
SearchFor output
ElseIf inLSM12 Then
Set output = thisWb.Sheets("LSM")
SearchFor output
End If
'End If
mybook.Close SaveChanges:=False
Set mybook = Nothing
End If
Else
MsgBox "We skipped this file : " & Fname(N) & " because it is already open."
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
' Change drive/directory back to SaveDriveDir.
ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Contributed by Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
I need to merge two Excel files, but only certain columns from each. I need to use a userform to select the two files to merge and then also use column mapping to select which columns from each sheet need appear where in the new output sheet.
So far I have this.
Private Sub AddFilesButton_Click()
Dim arrFiles As Variant
On Error GoTo ErrMsg
'Let the user choose the files they want to merge
#If Mac Then
arrFiles = Select_File_Or_Files_Mac()
#Else
arrFiles = Application.GetOpenFilename("Excel Files (*.xls; *.xlsx), *.xls;*.xlsx", 1, "Choose Excel Files", "Select", True)
#End If
If IsNull(arrFiles) Or UBound(arrFiles) = -1 Then
MsgBox "Please choose at least one Excel file"
Else
For Each file In arrFiles
FilesListBox.AddItem file
Next file
MergeButton.Enabled = True
End If
ErrMsg:
If Err.Number <> 0 Then
MsgBox "There was an error. Please try again. [" & Err.Description & "]"
End If
End Sub
Private Sub CancelButton_Click()
Unload Me
End Sub
Private Sub MergeButton_Click()
Dim fileName As Variant
Dim wb As Workbook
Dim s As Sheet1
Dim thisSheet As Sheet1
Dim lastUsedRow As Range
Dim columnMap As Collection
Dim filePath As Variant
Dim dataRange As Range
Dim insertAtRowNum As Integer
Dim outColName As String
Dim colName As String
Dim fromRange As String
Dim fromRangeToCopy As Range
Dim toRange As String
On Error GoTo ErrMsg
Application.ScreenUpdating = False
Set thisSheet = ThisWorkbook.ActiveSheet
For i = 0 To FilesListBox.ListCount - 1
fileName = FilesListBox.List(i, 0)
'Get the map of columns for this file
Set columnMap = MapColumns(fileName)
'Open the spreadsheet in ReadOnly mode
Set wb = Application.Workbooks.Open(fileName, ReadOnly:=True)
For Each sourceSheet In wb.Sheets
'Get the used range (i.e. cells with data) from the opened spreadsheet
If firstRowHeaders And i > 0 Then 'Only include headers from the first spreadsheet
Dim mr As Integer
mr = wb.ActiveSheet.UsedRange.Rows.Count
Set dataRange = wb.ActiveSheet.UsedRange.Offset(1, 0).Resize(mr - 1)
Else
Set dataRange = wb.ActiveSheet.UsedRange
End If
For Each col In dataRange.Columns
'Get corresponding output column. Empty string means no mapping
colName = GetColName(col.Column)
outColName = GetOutputColumn(columnMap, colName)
If outColName <> "" Then
fromRange = colName & 1 & ":" & colName & dataRange.Rows.Count
Set fromRangeToCopy = dataRange.Range(fromRange)
fromRangeToCopy.Copy
toRange = outColName & insertAtRowNum & ":" & outColName & (insertAtRowNum + fromRangeToCopy.Rows.Count - 1)
thisSheet.Range(toRange).PasteSpecial
End If
Next col
insertAtRowNum = insertAtRowNum + dataRange.Rows.Count
Next sourceSheet
Application.CutCopyMode = False
Next i
ThisWorkbook.Save
Set wb = Nothing
#If Mac Then
'Do nothing. Closing workbooks fails on Mac for some reason
#Else
'Close the workbooks except this one
Dim file As String
For i = 0 To FilesListBox.ListCount - 1
file = FilesListBox.List(i, 0)
file = Right(file, Len(file) - InStrRev(file, Application.PathSeparator, , 1))
Workbooks(file).Close SaveChanges:=False
Next i
#End If
Application.ScreenUpdating = True
Unload Me
ErrMsg:
If Err.Number <> 0 Then
MsgBox "There was an error. Please try again. [" & Err.Description & "]"
End If
End Sub
Function MapColumns(fileName As Variant) As Object
Dim colMap As New Collection
Select Case fileName
Case "ExcelFile1.xlsx"
colMap.Add Key:="C", Item:="A"
colMap.Add Key:="D", Item:="B"
colMap.Add Key:="E", Item:="C"
colMap.Add Key:="I", Item:="D"
Case "ExcelFile2.xlsx"
colMap.Add Key:="B", Item:="F"
colMap.Add Key:="J", Item:="G"
colMap.Add Key:="H", Item:="H"
colMap.Add Key:="C", Item:="I"
End Select
Set MapColumns = colMap
End Function
Function GetOutputColumn(columnMap As Collection, col As String) As String
Dim outCol As String
outCol = ""
If columnMap.Count > 0 Then
outCol = columnMap.Item(col)
End If
GetOutputColumn = outCol
End Function
'From: http://www.mrexcel.com/forum/excel-questions/16444-getting-column-name-given-column-number.html
Function GetColName(ColumnNumber)
FuncRange = Cells(1, ColumnNumber).AddressLocal(False, False) 'Creates Range (defaults Row to 1) and retuns Range in xlA1 format
FuncColLength = Len(FuncRange) 'finds length of range reference
GetColName = Left(FuncRange, FuncColLength - 1) 'row always "1" therefore take 1 away from string length and you are left with column ref
End Function
'From: http://msdn.microsoft.com/en-us/library/office/hh710200%28v=office.14%29.aspx#odc_xl4_ta_ProgrammaticallySelectFileforMac_DifferencesWindowsandMac
Function Select_File_Or_Files_Mac() As Variant
Dim MyPath As String
Dim MyScript As String
Dim MyFiles As String
Dim MySplit As Variant
Dim N As Long
Dim Fname As String
Dim mybook As Workbook
On Error Resume Next
MyPath = MacScript("return (path to documents folder) as String")
'Or use MyPath = "Macintosh HD:Users:Ron:Desktop:TestFolder:"
' In the following statement, change true to false in the line "multiple
' selections allowed true" if you do not want to be able to select more
' than one file. Additionally, if you want to filter for multiple files, change
' {""com.microsoft.Excel.xls""} to
' {""com.microsoft.excel.xls"",""public.comma-separated-values-text""}
' if you want to filter on xls and csv files, for example.
MyScript = _
"set applescript's text item delimiters to "","" " & vbNewLine & _
"set theFiles to (choose file of type " & _
" {""com.microsoft.Excel.xls"",""org.openxmlformats.spreadsheetml.sheet""} " & _
"with prompt ""Please select a file or files"" default location alias """ & _
MyPath & """ multiple selections allowed true) as string" & vbNewLine & _
"set applescript's text item delimiters to """" " & vbNewLine & _
"return theFiles"
MyFiles = MacScript(MyScript)
On Error GoTo 0
MySplit = False 'Assume no files = cancel
If MyFiles <> "" Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
MySplit = Split(MyFiles, ",")
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
Select_File_Or_Files_Mac = MySplit
End Function
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Contributed by Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function