Deleting directory in an array - arrays

I have this code that gets all file types.
Dim file as variant
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , True)
Then I have to print it in the cells on a sheet.
For i = 1 To UBound(file)
lRow = Cells(Rows.count, 15).End(xlUp).Row
lRow = lRow + 1
ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = CStr(file(i))
Next i
but what I want is first check the contents of the array. If the array has this file type, then I have to remove it in the arraylist. After that, a message will pop out that this files are removed.
dim arr() as string
arr = Split("ade|adp|app|asp|bas|bat|cer|chm|cmd|com|cpl|crt|csh|der|exe|fxp|gadget|hlp|hta|inf|ins|isp|its|js|jse|" _
& "ksh|lnk|mad|maf|mag|mam|maq|mar|mas|mat|mau|mav|maw|mda|mdb|mde|mdt|mdw|mdz|msc|msh|msh1|msh2|" _
& "mshxml|msh1xml|msh2xml|ade|adp|app|asp|bas|bat|cer|chm|cmd|com|cpl|crt|csh|der|exe|fxp|gadget|hlp|" _
& "hta|msi|msp|mst|ops|pcd|pif|plg|prf|prg|pst|reg|scf|scr|sct|shb|shs|ps1|ps1xml|ps2|ps2xml|psc1|psc2|tmp|url|vb|vbe|vbs|vsmacros|vsw|ws|wsc|wsf|wsh|xnk", "|")
I just don't know where I have to start. I have found a little bit same problem here in this post, but I just can't understand it. Thanks!

You can use a RegExp and a varaint array to do this quickly
This code looks for path... dot extension end string so it is more robust than your current array which may remove files based on the path name rather than file type
Sub B()
Dim fName As Variant
Dim objRegex As Object
Dim lngCnt As Long
Dim rng1 As Range
Set objRegex = CreateObject("vbscript.regexp")
On Error Resume Next
fName = Application.GetOpenFilename("All Files, *.*", , "Select file", , True)
If Err.Number <> 0 Then Exit Sub
On Error GoTo 0
With objRegex
.Pattern = ".*\.(ade|adp|app|asp|bas|bat|cer|chm|cmd|com|cpl|crt|csh|der|exe|fxp|gadget|hlp|hta|inf|ins|isp|its|js|jse|" _
& "ksh|lnk|mad|maf|mag|mam|maq|mar|mas|mat|mau|mav|maw|mda|mdb|mde|mdt|mdw|mdz|msc|msh|msh1|msh2|" _
& "mshxml|msh1xml|msh2xml|ade|adp|app|asp|bas|bat|cer|chm|cmd|com|cpl|crt|csh|der|exe|fxp|gadget|hlp|" _
& "hta|msi|msp|mst|ops|pcd|pif|plg|prf|prg|pst|reg|scf|scr|sct|shb|shs|ps1|ps1xml|ps2|ps2xml|psc1|psc2|tmp|url|vb|vbe|vbs|vsmacros|vsw|ws|wsc|wsf|wsh|xnk)$"
`replace matching file types with blank array entries
For lngCnt = 1 To UBound(fName)
fName(lngCnt) = .Replace(fName(lngCnt), vbNullString)
Next
End With
Set rng1 = Cells(Rows.Count, 15).End(xlUp).Offset(1,0)
'dump array to sheet
rng1.Resize(UBound(fName), 1) = Application.Transpose(fName)
` remove blank entries
On Error Resume Next
rng1.SpecialCells(xlCellTypeBlanks).Delete xlUp
On Error GoTo 0
End Sub

One way would be to check that the extension it's not present in the blacklist with InStr:
Const exts = _
".ade.adp.app.asp.bas.bat.cer.chm.cmd.com.cpl.crt.csh.der.exe.fxp.gadget" & _
".hlp.hta.inf.ins.isp.its.js.jse.ksh.lnk.mad.maf.mag.mam.maq.mar.mas.mat" & _
".mau.mav.maw.mda.mdb.mde.mdt.mdw.mdz.msc.msh.msh1.msh2.mshxml.msh1xml" & _
".msh2xml.ade.adp.app.asp.bas.bat.cer.chm.cmd.com.cpl.crt.csh.der.exe.fxp" & _
".gadget.hlp.hta.msi.msp.mst.ops.pcd.pif.plg.prf.prg.pst.reg.scf.scr.sct" & _
".shb.shs.ps1.ps1xml.ps2.ps2xml.psc1.psc2.tmp.url.vb.vbe.vbs.vsmacros.vsw" & _
".ws.wsc.wsf.wsh.xnk."
Dim file As Variant
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , True)
Dim i As Long, data(), count As Long, ext As String
ReDim data(1 To UBound(file) + 1, 1 To 1)
' filter the list
For i = LBound(file) To UBound(file)
ext = LCase(Mid(file(i), InStrRev(file(i), ".")))
If InStr(1, exts, ext & ".") = 0 Then ' if not blacklisted
count = count + 1
data(count, 1) = file(i)
End If
Next
' copy the filtered list to the next available row in column "O"
If count Then
With ThisWorkbook.Sheets("Main").Cells(Rows.count, "O").End(xlUp)
.Offset(1).Resize(count).Value = data
End With
End If

Related

Subscript out of range when trying to loop through array to read values

I have a string of predefined worksheets, that I need to run specific code for. I get a compile error.
The code is set up to copy data from one sheet to another.
How do I do the same for multiple sheets?
When I step through the code sht is showing the MHP60,MHP61,MHP62 and not just MHP60.
I get a subscript out of range error.
Sub Prepare_CYTD_Report()
Dim addresses() As String
Dim addresses2() As String
Dim SheetNames() As String
Dim SheetNames2() As String
Dim wb1 As Workbook, wb2 As Workbook
Dim my_Filename
'Declare variables for MHP60, MHP61, MHP62 Trial Balance Values
Dim i, lastcol As Long
Dim tabNames, cell As Range
Dim tabName As String
Dim sht As Variant
addresses = Strings.Split("A9,A12:A26,A32:A38,A42:A58,A62:A70,A73:A76,A83:A90", ",") 'Trial Balance string values
addresses2 = Strings.Split("G9,G12:G26,G32:G38,G42:G58,G62:G70,G73:G76,G83:G90", ",") 'Prior Month string values
SheetNames = Strings.Split("MHP60,MHP61,MHP62")
'SheetNames2 = Strings.Split("MHP60-CYTDprior,MHP61-CYTDprior,MHP62-CYTDprior")
Set wb1 = ActiveWorkbook 'Revenue & Expenditure Summary Workbook
'*****************************Open CYTD files
my_Filename = Application.GetOpenFilename(fileFilter:="Excel Files,*.xl*;*.xm*", Title:="Select File to create CYTD Reports")
If my_Filename = False Then
Exit Sub
End If
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(my_Filename)
'*****************************Load Column Header Strings & Copy Data
For Each sht In SheetNames
lastcol = wb1.Sheets(sht).Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames = wb1.Sheets(sht).Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP60", vbCritical
Exit Sub
End If
For Each cell In tabNames
tabName = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets(sht).Evaluate("ISREF('[" & wb2.Name & "]" & tabName & "'!$A$1)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName).Range(addresses(i)).Value2 = wb1.Sheets(sht).Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName & " was not found in " & wb2.Name
End If
Next cell
Next sht
MsgBox "CYTD Report Creation Complete", vbOKOnly
Application.ScreenUpdating = True
End Sub
Split by what?
SheetNames = Strings.Split("MHP60,MHP61,MHP62")
Split by comma? Then use the following instead:
SheetNames = Strings.Split("MHP60,MHP61,MHP62", ",")
Alternative
Dim SheetNames() As Variant ' needs to be Variant to work with Array()
SheetNames = Array("MHP60", "MHP61", "MHP62")
This should be quicker as your macro does not need to split the string and has it as array directly.

how to include file system object properties in excel vba dynamic array

I am trying to work out how to use filesystemobject to include date created, date modified, size, path, file/folder names of files and folders into an excel vba dynamic array so that it automatically expands or contracts to the list of files/folders.
In addition, I am trying to make a list of excluded folder paths so that when I click search, only those folder paths and its files are excluded from the result list, but other folders and its files are shown. Is it possible to make a list of folder paths which will exclude deeper nested folder subfolders?
For example, In this folder C:\test with spaces\ (see image) folder structure I want to exclude the file in C:\test with spaces\subfolder 1\2ndlevelsubfolder1\ including "2ndlevelsubfolder1", but I want all other folders paths to be displayed. How can I do this with vba?
Finally, I also want to make this list recursive, so that every time I add/remove the excluded list of folder paths, new entries will be added right after the previous list. I have these functions made in different excel workbooks but the only problem is incorporating them together into one code. I am showing you my code from 2 workbooks:
This code is for recursive listing:
Option Explicit
Sub SomeSub()
Call GetFiles("\\?\[INSERT PARENT FOLDER PATH HERE]") 'attach "\\?\" at the beginning for long folder path names! ex..'GetFiles("\\?\INSERT..."
'can also list multiple "Call GetFiles("\\?\[insert new folder path here]")" to list multiple folder paths all at once
End Sub
Sub GetFiles(ByVal path As String)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim folder As Object
Set folder = FSO.GetFolder(path)
Dim SubFolder As Object
Dim file As Object
For Each SubFolder In folder.Subfolders
GetFiles (SubFolder.path)
Next SubFolder
Range("A1") = "parent folder"
'Range("A1").Offset(0, 1) = "FILE/FOLDER PATH"
Range("A1").Offset(0, 3) = "FILE or FOLDER"
Range("A1").Offset(0, 4) = "DATE CREATED"
Range("A1").Offset(0, 5) = "DATE MODIFIED"
Range("A1").Offset(0, 6) = "SIZE"
Range("A1").Offset(0, 7) = "TYPE"
Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Replace(folder, "\\?\", "")
'Range("A" & Rows.Count).End(xlUp).Offset(0, 1) = Replace(folder, "\\?\", "")
'Range("A" & Rows.Count).End(xlUp).Offset(0, 2) = folder.Name
Range("A" & Rows.Count).End(xlUp).Offset(0, 3) = "FOLDER"
Range("A" & Rows.Count).End(xlUp).Offset(0, 4) = folder.datecreated
Range("A" & Rows.Count).End(xlUp).Offset(0, 5) = folder.DateLastModified
For Each SubFolder In folder.Subfolders
'Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Replace(subfolder.path, "\\?\", "")
'Range("A" & Rows.Count).End(xlUp).Offset(0, 1) = Replace(folder, "\\?\", "")
'Range("A" & Rows.Count).End(xlUp).Offset(0, 2) = subfolder.Name
'Range("A" & Rows.Count).End(xlUp).Offset(0, 3) = "FOLDER"
'Range("A" & Rows.Count).End(xlUp).Offset(0, 4) = subfolder.datecreated
'Range("A" & Rows.Count).End(xlUp).Offset(0, 5) = subfolder.DateLastModified
Next SubFolder
For Each file In folder.Files
Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Replace(file.path, "\\?\", "")
'Range("A" & Rows.Count).End(xlUp).Offset(0, 1) = Replace(folder, "\\?\", "")
'Range("A" & Rows.Count).End(xlUp).Offset(0, 2) = file.Name
Range("A" & Rows.Count).End(xlUp).Offset(0, 3) = "FILE"
Range("A" & Rows.Count).End(xlUp).Offset(0, 4) = file.datecreated
Range("A" & Rows.Count).End(xlUp).Offset(0, 5) = file.DateLastModified
Range("A" & Rows.Count).End(xlUp).Offset(0, 6) = file.Size
Range("A" & Rows.Count).End(xlUp).Offset(0, 7) = file.Type
Next file
With Range("E:F")
.NumberFormat = "dddd mmmm dd, yyyy H:mm:ss AM/PM" 'long file date and time
End With
Set FSO = Nothing
Set folder = Nothing
Set SubFolder = Nothing
Set file = Nothing
End Sub
This is the excluded folder name list code in cell A3 only the names are inserted at cell A3 seperated by commas with no spaces after the comma. I want folder paths at any subfolder level to be excluded, not just names at the 1st level
Option Explicit
'http://www.ozgrid.com/forum/showthread.php?t=158478
Dim iRow As Long
Sub ListFiles()
Dim lRow As Long
iRow = 11
lRow = Range("B" & Rows.Count).End(xlUp).Row
If lRow >= iRow Then
Range("B" & iRow & ":E" & Range("B" & Rows.Count).End(xlUp).Row).Clear
End If
Call ListMyFiles(Range("A1"), Range("A2"), Range("A3")) 'Cell A1 is the parent directory, A2 is include subfolders as false or true _
cell A3 is the exclude folder names within the parent directory _
which only works in the 1st level not deeper nested levels
Application.GoTo Range("B3"), True
End Sub
Sub ListMyFiles(mySourcePath As String, IncludeSubfolders As String, _
Optional excludedSubfolders As String = " ")
Dim myObject As Scripting.FileSystemObject
Dim mySource As Scripting.folder, myFile As Variant
Dim myfolder As Variant
Dim iCol As Integer
Dim mySubFolder As Scripting.folder, v As Variant
Dim asf() As String, sf As String
asf() = Split(Replace(excludedSubfolders, ", ", ","), ",")
Set myObject = New Scripting.FileSystemObject
If Right(mySourcePath, 1) <> "\" Then mySourcePath = mySourcePath + "\"
Set mySource = myObject.GetFolder(mySourcePath)
On Error Resume Next
For Each mySubFolder In mySource.SubFolders
iCol = 1
Cells(iRow, iCol).Value = mySubFolder.Path
iCol = iCol + 1
Cells(iRow, iCol).Value = mySubFolder.Name
iRow = iRow + 1
Next mySubFolder
If IncludeSubfolders Then
For Each mySubFolder In mySource.SubFolders
If excludedSubfolders = " " Then
Call ListMyFiles(mySubFolder.Path, True)
Else
sf = Trim(Right(mySubFolder.Path, Len(mySubFolder.Path) - Len(mySourcePath)))
If IndexStrArray(asf(), sf) = -1 Then Call ListMyFiles(mySubFolder.Path, True)
End If
Next
End If
End Sub
'val is not case sensitive
Function IndexStrArray(vArray() As String, sVal As String) As Long
Dim v As Variant, i As Long
On Error GoTo Minus1
For i = 0 To UBound(vArray)
If LCase(vArray(i)) = LCase(sVal) Then
IndexStrArray = i
Exit Function
End If
Next i
Minus1:
IndexStrArray = -1
End Function
I hope this has shed some light on what I want to achieve. Thank you & hope to hear from you soon.
Not sure it'll 100% match your needs.
You should use collections, and recursive sub, like this (not fully tested, it might needs some corrections):
' List of complete path of files in folder / subfolders
' Needs to add "Microsoft Scripting Runtime" reference to your file
Sub FolderFilesPath(ByVal pFolder As String, ByRef pColFiles As Collection, _
Optional ByVal pGetSubFolders As Boolean, Optional ByVal pFilter As Collection)
Dim sFolder As String
Dim oFSO As New FileSystemObject
Dim oFolder, oSubFolder As Folder
Dim oFile As File
sFolder = IIf(Right(pFolder, 1) <> "\", pFolder & "\", pFolder)
Set oFolder = oFSO.GetFolder(sFolder)
If Not ExistsInCollection(pFilter, oFolder) Then
For Each oFile In oFolder.Files
pColFiles.Add oFile
Next oFile
If pGetSubFolders Then
For Each oSubFolder In oFolder.SubFolders
FolderFilesPath oSubFolder.Path, pColFiles, pGetSubFolders,
pFilter
Next
End If
End If
End Sub
' Vba collection contains
Function ExistsInCollection(col As Collection, key As Variant) As Boolean
On Error GoTo err
ExistsInCollection = True
IsObject (col.Item(key))
Exit Function
err:
ExistsInCollection = False
End Function
'------------------------------------------------------------------------------
Sub TestMe()
Dim colFiles As New Collection, sFilePath As Variant
Dim colExcludedFolders As New Collection
With colExcludedFolders
.Add "C:\test with spaces\subfolder 1\"
End With
FolderFilesPath ThisWorkbook.Path, colFiles, True, colExcludedFolders
' colFiles contains filtered files
For Each sFilePath In colFiles
With sFilePath
Debug.Print .Path & " - " & .Name & " - " & .DateCreated
End With
Next sFilePath
End Sub
Now i am getting Run-time error '28': Out of stack space
What is wrong with this code?

remove duplicates from an array - vba

I have a code, that grabs data from a column of a file, and puts it into an array.
now, I want to go through this array and delete duplicates but I can't make it go through... any ideas?
this is the code, and the array is at the end:
Dim i As Long
Dim searchItem As Variant
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
With s_wbk.Worksheets("Sheet1")
For i = 1 To Rows.Count
If Not IsEmpty(Cells(i, 1).Value) Then
strSearch = strSearch & "," & Cells(i, 1).Value
End If
Next i
End With
s_wbk.Close
searchItem = Split(strSearch, ",") '*NEED TO REMOVE DUPLICATES
Remove the duplicates during the string construction by testing for prior existence with InStr function.
If Not IsEmpty(Cells(i, 1).Value) And _
Not InStr(1, strSearch, Cells(i, 1).Value & ",", vbTextCompare) Then
strSearch = strSearch & "," & Cells(i, 1).Value
End If
You should also remove the last trailing comma before splitting.
Next i
strSearch = Left(strSearch, Len(strSearch) - 1)
Finally, if you had added the values into a Scripting.Dictionary object (which comes with its own unique primary key index), you would have a unique set of keys in an array already built for you.
This worked for me:
Function removeDuplicates(ByVal myArray As Variant) As Variant
Dim d As Object
Dim v As Variant 'Value for function
Dim outputArray() As Variant
Dim i As Integer
Set d = CreateObject("Scripting.Dictionary")
For i = LBound(myArray) To UBound(myArray)
d(myArray(i)) = 1
Next i
i = 0
For Each v In d.Keys()
ReDim Preserve outputArray(0 To i)
outputArray(i) = v
i = i + 1
Next v
removeDuplicates = outputArray
End Function
Hope it helps
Easiest way would be to duplicate the sheet you take your input from and use built-in function to get rid of the duplicates, take a look at this :
Dim i As Long
Dim searchItem As Variant
Dim Ws As Worksheet
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
'Copy the sheet
s_wbk.Sheets("Sheet1").Copy (s_wbk.Sheets(1))
Set Ws = s_wbk.Sheets(1)
With Ws
'Remove duplicates from column A
With .Range("A:A")
.Value = .Value
.RemoveDuplicates _
Columns:=Array(1), _
Header:=xlNo
End With
For i = 1 To .Range("A" & .Rows.count).End(xlUp).Row
If Not IsEmpty(.Cells(i, 1)) Then
strSearch = strSearch & "," & .Cells(i, 1).Value
End If
Next i
'Get rid of that new sheet
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = False
End With
s_wbk.Close
searchItem = Split(strSearch, ",") 'NO MORE DUPLICATES ;)
Or even faster (as you won't have empty cells in the range after the RemoveDuplicates) :
Dim i As Long
Dim searchItem As Variant
Dim Ws As Worksheet
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
'Copy the sheet
s_wbk.Sheets("Sheet1").Copy (s_wbk.Sheets(1))
Set Ws = s_wbk.Sheets(1)
With Ws
'Remove duplicates from column A
With .Range("A:A")
.Value = .Value
.RemoveDuplicates _
Columns:=Array(1), _
Header:=xlNo
End With
'NO MORE DUPLICATES and FASTER ARRAY FILL ;)
searchItem = .Range(.Range("A1"), .Range("A" & .Rows.count).End(xlUp)).Value
'Get rid of that new sheet
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = False
End With
s_wbk.Close
Usually I use a dictionary object to check for duplicates, or use it itself. A dictionary is an object that references unique keys to values. Since the keys have to be unique it is quite usable for collecting unique values. Maybe it is not the most memory efficient way and probaby a little abues of the object, but it works quite fine.
You have to dim an object and set it to a dictionary, collect the data, after checking it doesn't already exist and then loop through the dictionary to collect the values.
Dim i As Long
Dim searchItem As Variant, var as variant
dim dicUniques as object
set dicUniques = CreateObject("Scripting.Dictionary")
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
With s_wbk.Worksheets("Sheet1")
For i = 1 To Rows.Count
If Not IsEmpty(Cells(i, 1).Value) Then
if dicUniques.exists(cells(i,1).value) = false then
dicUniques.add cells(i,1).value, cells(i,1).value
end if
End If
Next i
End With
s_wbk.Close
for each var in dicUniques.keys
strSearch = strSearch & ", " & var
next var
searchItem = Split(strSearch, ",")
That's the quick and dirty solution. Since the keys are unique you could probably use them by themselves, without putting them together in the string first.
By the way: First of all, you shoudl specify which cells you use. Sometimes you start the macro form another worksheet and then it will use the cells there, if no parent worksheet is given for the cells object.
Second, it is important to specify you want to use the cells value for the dictionary, since a dictionary object can contain anything. So if you don't use cells(x,y).value the object will contain the cell itself.
edit: Corrected typo in the routine.
Unique Column To Array
Option Explicit
Sub removeDuplicates()
Const strFile = "...\Desktop\xl files min\src.xlsm"
Const SheetName As String = "Sheet1"
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const FirstRow As Long = 2
Dim s_wbk As Workbook
Dim SourceArray, WorkArray, searchItem
Set s_wbk = Workbooks.Open(strFile)
SourceArray = copyColumnToArray(s_wbk.Worksheets(SheetName), _
FirstRow, SourceColumn)
s_wbk.Close
If Not IsArray(SourceArray) Then Exit Sub
WorkArray = Application.Transpose(SourceArray) ' only up to 65536 elements.
searchItem = getUniqueArray(WorkArray)
End Sub
Function copyColumnToArray(SourceSheet As Worksheet, _
FirstRowNumber As Long, ColumnNumberLetter As Variant) As Variant
Dim rng As Range
Dim LastRowNumber As Long
Set rng = SourceSheet.Columns(ColumnNumberLetter).Find(What:="*", _
LookIn:=xlFormulas, Searchdirection:=xlPrevious)
If rng Is Nothing Then Exit Function
Set rng = SourceSheet.Range(SourceSheet _
.Cells(FirstRowNumber, ColumnNumberLetter), rng)
If Not rng Is Nothing Then copyColumnToArray = rng
End Function
Function getUniqueArray(SourceArray As Variant, _
Optional Transpose65536 As Boolean = False) As Variant
' Either Late Binding ...
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
' ... or Early Binding:
' VBE > Tools > References > Microsoft Scripting Runtime
'Dim dict As Scripting.Dictionary: Set dict = New Scripting.Dictionary
Dim i As Long
For i = LBound(SourceArray) To UBound(SourceArray)
If SourceArray(i) <> Empty Then
dict(SourceArray(i)) = Empty
End If
Next i
' Normal: Horizontal (Row)
If Not Transpose65536 Then getUniqueArray = dict.Keys: GoTo exitProcedure
' Transposed: Vertical (Column)
If dict.Count <= 65536 Then _
getUniqueArray = Application.Transpose(dict.Keys): GoTo exitProcedure
' Transpose only supports up to 65536 items (elements).
MsgBox "Source Array contains '" & dict.Count & "' unique values." _
& "Transpose only supports up to 65536 items (elements).", vbCritical, _
"Custom Error Message: Too Many Elements"
exitProcedure:
End Function

VBA Directory File Search using list within Excel

I'm currently trying to edit a macro a colleague of mine currently uses, the script currently opens a message box that allows you to enter in a string, which is then searched for and results are pasted into the workbook. I would like to change this so it searches for a list already within the spreadsheet, and then for the results to be pasted on the next worksheet. I'm not sure if this is actually possible or not, which is where my main struggle is. Below is the current code, I assume all that is needed is for the variable range to be placed in that stars "msg = "Enter file name and Extension"
Sub Filesearch()
Dim myDir As String, temp(), myList, myExtension As String
Dim SearchSubFolders As Boolean, Rtn As Integer, msg As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
myDir = .SelectedItems(1)
End If
End With
msg = "Enter File name and Extension" & vbLf & "following wild" & _
" cards can be used" & vbLf & "* # ?"
myExtension = Application.InputBox(msg)
If (myExtension = "False") + (myExtension = "") Then Exit Sub
Rtn = MsgBox("Include Sub Folders ?", vbYesNo)
SearchSubFolders = Rtn = 6
myList = SearchFiles(myDir, myExtension, 0, temp(), SearchSubFolders)
If Not IsError(myList) Then
Sheets(1).Cells(1).Resize(UBound(myList, 2), 2).Value = _
Application.Transpose(myList)
Else
MsgBox "No file found"
End If
End Sub
Private Function SearchFiles(myDir As String _
, myFileName As String, n As Long, myList() _
, Optional SearchSub As Boolean = False) As Variant
Dim fso As Object, myFolder As Object, myFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.getfolder(myDir).Files
Select Case myFile.Attributes
Case 2, 4, 6, 34
Case Else
If (Not myFile.Name Like "~$*") _
* (myFile.Path & "\" & myFile.Name <> ThisWorkbook.FullName) _
* (UCase(myFile.Name) Like UCase(myFileName)) Then
n = n + 1
ReDim Preserve myList(1 To 2, 1 To n)
myList(1, n) = myDir
myList(2, n) = myFile.Name
End If
End Select
Next
If SearchSub Then
For Each myFolder In fso.getfolder(myDir).subfolders
SearchFiles = SearchFiles(myFolder.Path, myFileName, _
n, myList, SearchSub)
Next
End If
SearchFiles = IIf(n > 0, myList, CVErr(xlErrRef))
End Function
Suggest the use of Defined Name Ranges to hold the user maintained list (as show in the picture below)
Let’s add a worksheet for user input of the requirements called “_Tables”.
Then create Defined Name Ranges, for users to enter the requirements, called "_Path", "_Files" and "_SubFldrs"
Then replace all the user’s input in current code
REPLACE THIS
''' With Application.FileDialog(msoFileDialogFolderPicker)
''' If .Show Then
''' myDir = .SelectedItems(1)
''' End If
''' End With
''' msg = "Enter File name and Extension" & vbLf & "following wild" & _
''' " cards can be used" & vbLf & "* # ?"
''' myExtension = Application.InputBox(msg)
''' If (myExtension = "False") + (myExtension = "") Then Exit Sub
''' Rtn = MsgBox("Include Sub Folders ?", vbYesNo)
''' SearchSubFolders = Rtn = 6
with this in order to read the requirements from the worksheet "_Tables"
Set WshLst = ThisWorkbook.Sheets("_Tables")
sPath = WshLst.Range("_Path").Value2
aFleKey = WshLst.Range("_Files").Value2
bSbFldr = UCase(WshLst.Range("_SubFldrs").Value2) = UCase("YES")
aFleKey = WorksheetFunction.Transpose(aFleKey)
then Process the lists
See below the entire code below. It's necessary to have the statement Option Base 1 at the top of the module
Option Explicit
Option Base 1
Sub Fle_FileSearch_List()
Dim WshLst As Worksheet
Dim sPath As String
Dim aFleKey As Variant, vFleKey As Variant
Dim bSbFldr As Boolean
Dim vFleLst() As Variant
Dim lN As Long
Set WshLst = ThisWorkbook.Sheets("_Tables")
sPath = WshLst.Range("_Path").Value2
aFleKey = WshLst.Range("_Files").Value2
bSbFldr = UCase(WshLst.Range("_SubFldrs").Value2) = UCase("YES")
aFleKey = WorksheetFunction.Transpose(aFleKey)
Rem To clear output location
ThisWorkbook.Sheets(1).Columns(1).Resize(, 2).Clear
Rem Process input list
For Each vFleKey In aFleKey
If (vFleKey <> "False") * (vFleKey <> "") Then
Call Fle_FileSearch_Fldrs(sPath, CStr(vFleKey), lN, vFleLst, bSbFldr)
End If: Next
Rem Validate Results & List Files found
If lN > 1 Then
ThisWorkbook.Sheets(1).Cells(1).Resize(UBound(vFleLst, 2), 2) _
.Value = Application.Transpose(vFleLst)
Else
MsgBox "No file found"
End If
End Sub
Also some adjustments to the function (now a procedure) to allow the process of the list.
Sub Fle_FileSearch_Fldrs(sPath As String, _
sFleKey As String, lN As Long, vFleLst() As Variant, _
Optional bSbFldr As Boolean = False)
Dim oFso As Object, oFolder As Object, oFile As Object
Set oFso = CreateObject("Scripting.FileSystemObject")
If lN = 0 Then
lN = 1 + lN
ReDim Preserve vFleLst(1 To 2, 1 To lN)
vFleLst(1, lN) = "Files Found - Path"
vFleLst(2, lN) = "Files Found - Name"
End If
For Each oFile In oFso.GetFolder(sPath).Files
Select Case oFile.Attributes
Case 2, 4, 6, 34
Case Else
If (Not oFile.Name Like "~$*") * _
(oFile.Path & "\" & oFile.Name <> ThisWorkbook.FullName) * _
(UCase(oFile.Name) Like UCase(sFleKey)) Then
lN = lN + 1
ReDim Preserve vFleLst(1 To 2, 1 To lN)
vFleLst(1, lN) = sPath
vFleLst(2, lN) = oFile.Name
End If: End Select: Next
If bSbFldr Then
For Each oFolder In oFso.GetFolder(sPath).subfolders
Call Fle_FileSearch_Fldrs(oFolder.Path, sFleKey, lN, vFleLst, bSbFldr)
Next: End If
End Sub

Activate windows of files stored in arrays, but getting subscript out of range error?

Sub Merge()
Dim File As String
Dim AllFiles(), Filename As Variant
Dim count, test, StartRow, LastRow, LastColumn As Long
Dim LastCell As Variant
test = 0
ChDir "C:\" 'Insert suitable directory for your computer ex:ChDir "C:\Users\Jerry Hou\" if file of interest is in "Jerry Hou" Folder
ReDim AllFiles(1)
Do
Application.EnableCancelKey = xlDisabled
File = Application.GetOpenFilename("XML Files (*.xml),*.xml", 1, "Select File to be Merged") 'Needs to select in Order to merge files
Application.EnableCancelKey = xlErrorHandler
If (File = "False") Then Exit Do
ReDim Preserve AllFiles(count) 'Preserve ?
AllFiles(count) = File 'File== file name and directory
count = (count + 1)
If (MsgBox("Select Another File To be Merged With?", vbQuestion + vbOKCancel, "Merge Files") = vbCancel) Then Exit Do
Loop 'Select Cancel in MsgBox to finish merge file(s) selection
If (count = 0) Then
MsgBox "No selection" 'If you hit Exit from open prompt window
Exit Sub
End If
For count = 0 To UBound(AllFiles)
MsgBox "User selected file name: " & AllFiles(count)
Next
test = count
For test = UBound(AllFiles) To LBound(AllFiles) Step -1
Workbooks.Open Filename:=AllFiles(test)
Next
ReDim AllFiles(count)
test = 2
Do While (test <= count)
Filename = AllFiles(test)
Workbooks(AllFiles(test)).Activate 'ERROR Brings 2nd file that the user had selected to Last xml file selected in order to Front
'Copy and Paste TMG tab
Sheets("TMG_4 0").Activate
StartRow = 2
LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastColumn = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastCell = Cells(LastRow, LastColumn).Address 'Find lastcell of to be copied file
Range("A2:" & LastCell).Select
Selection.Copy
Windows("Allfiles(1).xml").Activate 'ERROR
Sheets("TMG_4 0").Activate
LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRow = LastRow + 1
Range("LastRow").Select 'ERROR
ActiveSheet.Paste
'Copy and Paste Gamma tab
Sheets("GammaCPS 0").Activate
StartRow = 2
LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastColumn = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastCell = Cells(LastRow, LastColumn).Address
Range("A2:" & LastCell).Select
Selection.Copy
Windows("Allfiles(1).xml").Activate 'ERROR Windows("File_name.xlsm").activate
Sheets("GammaCPS 0").Activate
LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRow = LastRow + 1
Range("LastRow").Select 'ERROR
ActiveSheet.Paste
test = test + 1
Loop
Windows("Allfiles(1).xml").Activate 'ERROR
ActiveWorkbook.SaveAs Filename:="C:\" & AllFiles(1) & AllFiles(test) & ".xlsm", FileFormat:=52
End Sub
You redim AllFiles but never fill it with anything. Is there missing code?
AllFiles is a 0 based array so if you want to start at the second element you need to use test = 1 instead of test = 2.
For looping through an array, try this:
For test = 1 to ubound(AllFiles) - 1 'This loops through the array from the second element to the last
Is "LastRow" a named range? If not, that's not going to work. The following will select the last used row in a worksheet:
activesheet.Rows(activesheet.usedrange.rows.count).select
Your SaveAs is failing because 1) AllFiles looks like it's never filled and 2) your save path as you wrote would be literally: C:\Allfile(1)&Allfiles(count)\.xlsm. You want:
ActiveWorkbook.SaveAs Filename:= "C:\" & AllFiles(1) & AllFiles(test) & ".xlsm"
EDIT After Code Update
You never initialize your count variable, add count = 0 to the beginning just to be safe.
GetOpenFilename does in fact return the full path. Once you have that path stored in a variable (such as AllFiles()) you can get just the filename portion with mid(AllFiles(test), instrrev(AllFiles(test), "\") + 1)
You don't need the ReDim AllFiles(count) prior to your main Do Loop. ReDim erases the contents of the array unless you use the Preserve keyword.
Change Workbooks(AllFiles(test)).Activate to Workbooks(Mid(AllFiles(test), InStrRev(AllFiles(test), "\") + 1)).Activate to strip the path information and leave just the filename.
Windows("Allfiles(1).xml").Activate won't work since your sending a literal string. You want WORKBOOKS(Mid(AllFiles(1), InStrRev(AllFiles(1), "\") + 1)).Activate here again.
LastRow = LastRow + 1 probably isn't what you meant. Try Set LastRow = LastRow.Offset(1, 0)
Change Range("LastRow").Select to LastRow.select
All instances of Windows( should be changed to Workbooks(

Resources