I have this code that gets all file types. Then if it has the extensions in the array, it should be stored in the excludedFile array and will be displayed after execution.
Dim excludedFile() as String
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"
Dim file As Variant
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , True)
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)
Else 'I've tried this but returns Subscript out of range error
excludedFile(UBound(excludedFile)) = file(i)
ReDim Preserve excludedFile(1 To UBound(excludedFile) + 1) As String
found = true
End If
Next
if found then
MsgBox Join(excludedFile, vbCrLf)
end if
Any help is appreciated. Thanks.
Not the most elegant way, but working
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"
Dim file As Variant
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , True)
'Dim your Array and a Counter
Dim excludedFile() As String
Dim efCount As Integer
ReDim Data(1 To UBound(file) + 1, 1 To 1)
efCount = 0
' 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)
Else 'I've tried this but returns Subscript out of range error
'Use counter to access array
ReDim Preserve excludedFile(efCount)
excludedFile(efCount) = file(i)
efCount = efCount + 1
found = True
End If
Next
If found Then
MsgBox Join(excludedFile, vbCrLf)
End If
Related
I want a cod that will find duplicates and return it in separate array.
So I found a code that would be perfect for me, but the thing is that this code is removing duplicates. I thought that it will be a simple job to change it, but somehow I cannot manage to do it....
I was thinking that it will be in this part of code If Err.Number <> 0 Then coll.Remove txt but have no idea how to change it. I have tried changing <> with = but it seems not to work.
Can someone tell me where and how should I change the code to get duplicates from 2 arrays.
Sub test()
Dim arr1 As Variant
Dim arr2 As Variant
Dim arr3 As Variant
Dim coll As Collection
Dim I As Long, j As Long, ii As Long, txt As String, x
With Worksheets("Sheet1")
LastRowColumnA = .Cells(.Rows.Count, 1).End(xlUp).Row
arr1 = .Range("A2:C" & LastRowColumnA).Value
End With
With Worksheets("Sheet2")
LastRowColumnA = .Cells(.Rows.Count, 1).End(xlUp).Row
arr2 = .Range("A2:C" & LastRowColumnA).Value
End With
Set coll = New Collection
On Error Resume Next
For I = LBound(arr1, 1) To UBound(arr1, 1)
txt = Join(Array(arr1(I, 1), arr1(I, 2), arr1(I, 3)), Chr(2))
coll.Add txt, txt
Next I
For I = LBound(arr2, 1) To UBound(arr2, 1)
txt = Join(Array(arr2(I, 1), arr2(I, 2), arr2(I, 3)), Chr(2))
Err.Clear
coll.Add txt, txt
If Err.Number <> 0 Then coll.Remove txt
Next I
ReDim arr3(1 To coll.Count, 1 To 3)
For I = 1 To coll.Count
x = Split(coll(I), Chr(2))
For ii = 0 To 2
arr3(I, ii + 1) = x(ii)
Next
Next I
Worksheets("test").Range("A2").Resize(UBound(arr3, 1), 3).Value = arr3
Columns("A:C").EntireColumn.AutoFit
End Sub
Regards,
Timonek
Extract Duplicates
If you set CountSameWorksheetDuplicates to True, it will return the duplicates of each worksheet even if they are not found in the other worksheet.
Option Explicit
Sub ExtractDuplicates()
Const sName1 As String = "Sheet1"
Const sCols1 As String = "A:C"
Const sfRow1 As Long = 2
Const sName2 As String = "Sheet2"
Const sCols2 As String = "A:C"
Const sfRow2 As Long = 2
Const dName As String = "Test"
Const dfCellAddress As String = "A2"
Const CountSameWorksheetDuplicates As Boolean = False
Dim Delimiter As String: Delimiter = Chr(2)
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sData As Variant
sData = RefColumns(wb.Worksheets(sName1).Rows(sfRow1).Columns(sCols1))
Dim cCount As Long: cCount = UBound(sData, 2)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long
Dim sKey As Variant
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
If CountSameWorksheetDuplicates Then
DictAddCount dict, sKey
Else
DictAdd dict, sKey, 1
End If
Next r
sData = RefColumns(wb.Worksheets(sName2).Rows(sfRow2).Columns(sCols2))
If CountSameWorksheetDuplicates Then
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
DictAddCount dict, sKey
Next r
Else
Dim dict2 As Object: Set dict2 = CreateObject("Scripting.Dictionary")
dict2.CompareMode = vbTextCompare
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
DictAdd dict2, sKey
Next r
For Each sKey In dict2.Keys
DictAddCount dict, sKey
Next sKey
Set dict2 = Nothing
End If
Erase sData
For Each sKey In dict.Keys
If dict(sKey) = 1 Then dict.Remove sKey
Next sKey
Dim drCount As Long: drCount = dict.Count
If drCount = 0 Then Exit Sub
Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
r = 0
Dim c As Long
For Each sKey In dict.Keys
sData = Split(sKey, Delimiter)
r = r + 1
For c = 1 To cCount
dData(r, c) = sData(c - 1)
Next c
Next sKey
Dim drg As Range
Set drg = wb.Worksheets(dName).Range(dfCellAddress).Resize(drCount, cCount)
drg.Value = dData
drg.Resize(drg.Worksheet.Rows.Count - drg.Row - drCount + 1) _
.Offset(drCount).Clear ' clear below
drg.EntireColumn.AutoFit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the range from the first row of a range
' ('FirstRowRange') to the row range containing
' the bottom-most non-empty cell in the row's columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumns( _
ByVal FirstRowRange As Range) _
As Range
If FirstRowRange Is Nothing Then Exit Function
With FirstRowRange.Rows(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Function ' empty range
Set RefColumns = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a row of a 2D array in a delimited string.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function StrJoinedDataRow( _
ByVal Data As Variant, _
ByVal RowIndex As Long, _
Optional ByVal Delimiter As String = " ") _
As String
Const ProcName As String = "StrJoinedDataRow"
On Error GoTo ClearError
Dim c As Long
Dim cString As String
For c = LBound(Data, 2) To UBound(Data, 2)
cString = cString & CStr(Data(RowIndex, c)) & Delimiter
Next c
StrJoinedDataRow = Left(cString, Len(cString) - Len(Delimiter))
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Adds a value ('Key') to a key of an existing ('ByRef')
' dictionary ('dict') adding another value ('Item')
' to the key's associated item.
' Remarks: Error and blank values are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAdd( _
ByRef dict As Object, _
ByVal Key As Variant, _
Optional ByVal Item As Variant = Empty)
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = Item
End If
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Adds a value ('Key') to a key of an existing ('ByRef')
' dictionary ('dict') increasing its count being held
' in the key's associated item.
' Remarks: Error and blank values are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAddCount( _
ByRef dict As Object, _
ByVal Key As Variant)
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = dict(Key) + 1
End If
End If
End Sub
Dim Dict as Object
Dict = CreateObject("Scripting.Dictionary")
Dim Line As Object
For Each line in MyArray
On Error Resume Next
Dict.Add(Line, "")
On Error Goto 0
Next
Dictionaries don't allow duplicate keys. We are only setting keys and ignoring the value by not setting it. The dictionary raises an error if the key exists.
I have a huge challenge which is: Search a massive database, a list of products. This database is divided into 3 dif. sheets. The result should be stored on a 4th sheet and organized by date in columns and summarized by quantity. Each database sheet has the same format (Product / Date / Quantity).
I was told that a vba array would work perfectly.
Any help will be very appreciated.
Thanksenter image description here
Pivot (Multiple Worksheets)
The Code
Option Explicit
Sub PivotMulti()
' Data
Const srcList As String = "Sheet1,Sheet2,Sheet3"
Const srcFirst As String = "A2"
' Destination
Const dstName As String = "SUMMARY"
Const dstFirst As String = "B2"
Const TitlesList As String = "Source Data,Product"
' Other
Const Delimiter As String = "###"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Define Data Ranges and write their values to arrays of Data Array.
Dim srcNames() As String: srcNames = Split(srcList, ",")
Dim sUpper As Long: sUpper = UBound(srcNames)
Dim Data As Variant: ReDim Data(0 To sUpper)
Dim rng As Range
Dim dCount As Long
Dim n As Long
For n = 0 To sUpper
With wb.Worksheets(srcNames(n)).Range(srcFirst)
Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1).Find( _
What:="*", _
LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
Data(n) = .Resize(rng.Row - .Row + 1, 3).Value
dCount = dCount + UBound(Data(n))
End With
Next n
' Define data structures.
Dim dictS As Object: Set dictS = CreateObject("Scripting.Dictionary")
dictS.CompareMode = vbTextCompare
Dim dictD As Object: Set dictD = CreateObject("Scripting.Dictionary")
Dim arlS As Object: Set arlS = CreateObject("System.Collections.ArrayList")
Dim arlD As Object: Set arlD = CreateObject("System.Collections.ArrayList")
' Declare additional variables.
Dim CurrString As String
Dim CurrDate As Date
Dim i As Long
Dim j As Long
Dim k As Long
' Write values from Data Array to dictionaries and array lists
' (dictianaries for 'unique' and 'sum', array lists for 'sort').
For n = 0 To sUpper
For i = 1 To UBound(Data(n), 1)
CurrDate = Data(n)(i, 2)
If Not dictD.Exists(CurrDate) Then
arlD.Add CurrDate
dictD(CurrDate) = Empty
End If
CurrString = Data(n)(i, 1) & Delimiter & srcNames(n) & Delimiter _
& Format(CurrDate, "yyyymmdd") & Delimiter & CurrDate
dictS(CurrString) = dictS(CurrString) + Data(n)(i, 3)
Next i
Next n
Set dictD = Nothing
Erase Data
Erase srcNames
arlD.Sort
Dim Key As Variant
For Each Key In dictS.Keys
arlS.Add Key & Delimiter & dictS(Key)
Next Key
Set dictS = Nothing
arlS.Sort
' Define Result Array.
Dim rrCount As Long: rrCount = 1 + arlS.Count
Dim rcCount As Long: rcCount = 2 + arlD.Count
Dim Result As Variant: ReDim Result(1 To rrCount, 1 To rcCount)
' Write headers.
Dim Titles() As String: Titles = Split(TitlesList, ",")
Result(1, 1) = Titles(0)
Result(1, 2) = Titles(1)
Erase Titles
j = 2
For Each Key In arlD
j = j + 1
Result(1, j) = Key
Next Key
' Write 'body'.
Dim Current() As String
Dim Previous(0 To 1) As String
i = 1
For Each Key In arlS
i = i + 1
Current = Split(Key, Delimiter)
If Current(0) <> Previous(0) Or Current(1) <> Previous(1) Then
For j = 1 To 2
Result(i, j) = Current(2 - j)
Next j
Else
i = i - 1
End If
CurrDate = CDate(Current(3))
Result(i, 3 + arlD.IndexOf(CurrDate, 0)) = CDbl(Current(4))
Previous(0) = Current(0)
Previous(1) = Current(1)
Next Key
Set arlD = Nothing
Set arlS = Nothing
' Write values from Result Array to Destination Range.
With wb.Worksheets(dstName).Range(dstFirst).Resize(, rcCount)
Application.ScreenUpdating = False
' Worksheet
.Worksheet.Cells.Clear
' Range
With .Resize(i)
.Value = Result ' Write.
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
' Headers
.Font.Bold = True
.Interior.Color = vbYellow
' Body
With .Resize(i - 1).Offset(1)
'.Font.Color = vbRed
End With
' Columns
.Columns.AutoFit
Application.ScreenUpdating = True
End With
MsgBox "Data transferred.", vbInformation, "Success"
End Sub
I have a database of about 140,000 test files. I am looking to loop through each folder and pull information from the file name of text and excel files so as to organize the data a little better.
I have found ways to pick a folder path and import information about each file using the code below. This works great except I would like to only pull information from excel and text files and I would also like to pull additional text information from the filename as well. For example I might have a file named:
"444555_CAT1010EL_650-700-800C-2hr laging NOT CH4.txt"
And I would want to print:
the 6 numbers at the beginning of the name (they could be anything) in this example "444555" in one column
print the 3 letters (they could be anything) before "1010EL" in another column. In this example "CAT"
"CH4" in the final column OR even have a column for "CH4" and if the filename contains "CH4" put an X in that column
have a column for "laging" and if the filename contains "laging" anywhere put an X in that column
Thank you in advance for your help.
Sub Compile3()
Dim oShell As Object
Dim oFile As Object
Dim oFldr As Object
Dim lRow As Long
Dim iCol As Integer
Dim vArray As Variant
vArray = Array(10, 0, 1, 156, 2, 4, 144, 146, 183, 185)
'0=Name, 31=Dimensions, 1=Size, 163=Vertical Resolution
Set oShell = CreateObject("Shell.Application")
'-------------------ROW INFO INPUT OPTIONS-----------------
'' 1)
' lRow = 1
' 2) find first empty row in database for bottletracker
'
Dim iRow As Long
iRow = Cells.find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
lRow = iRow
'------------------------------------------------------------
With Application.FileDialog(msoFileDialogFolderPicker)
.title = "Select the Folder..."
If .Show Then
Set oFldr = oShell.Namespace(.SelectedItems(1))
With oFldr
'Column header information
For iCol = LBound(vArray) To UBound(vArray)
Cells(lRow, iCol + 4) = .getdetailsof(.items, vArray(iCol))
Next iCol
For Each oFile In .items
lRow = lRow + 1
For iCol = LBound(vArray) To UBound(vArray)
Cells(lRow, iCol + 4) = .getdetailsof(oFile, vArray(iCol))
Next iCol
Next oFile
End With
End If
End With
End Sub
I'd use this code. There's three separate procedures at the end that find the last cell on the sheet, return the folder and return all files within the folder.
The main code then looks at each file name and pulls the required information from it.
Note, this code: InStr(sFileName, "CAT") <> 0 will return TRUE/FALSE depending if the text "CAT" is within the file name. InStr(sFileName, "CAT") returns the position of "CAT" within the text, and <>0 turns that into a boolean depending on if it's different from 0.
Option Explicit
Public Sub Test()
Dim sFolder As String
Dim cFiles As Collection
Dim vFile As Variant
Dim sFileName As String
Dim rLastCell As Range
sFolder = GetFolder("S:\DB_Development_DBC\") & Application.PathSeparator
Set cFiles = New Collection
EnumerateFiles sFolder, "*.xls*", cFiles
EnumerateFiles sFolder, "*.txt", cFiles
With ThisWorkbook.Worksheets("Sheet1")
For Each vFile In cFiles
Set rLastCell = LastCell(ThisWorkbook.Worksheets("Sheet1")).Offset(1) 'Find last row
sFileName = Mid(vFile, InStrRev(vFile, Application.PathSeparator) + 1) 'Get just file name from path.
.Cells(rLastCell.Row, 1) = Left(sFileName, 6) 'First 6 characters.
.Cells(rLastCell.Row, 2) = Mid(sFileName, InStr(sFileName, "1010EL") - 3, 3) '3 characters before 1010EL.
.Cells(rLastCell.Row, 3) = InStr(sFileName, "CH4") <> 0 'Contains CH4.
.Cells(rLastCell.Row, 4) = InStr(sFileName, "laging") <> 0 'Contains laging.
Next vFile
End With
End Sub
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub
Function GetFolder(Optional startFolder As Variant = -1) As Variant
Dim fldr As FileDialog
Dim vItem As Variant
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
If startFolder = -1 Then
.InitialFileName = Application.DefaultFilePath
Else
If Right(startFolder, 1) <> "\" Then
.InitialFileName = startFolder & "\"
Else
.InitialFileName = startFolder
End If
End If
If .Show <> -1 Then GoTo NextCode
vItem = .SelectedItems(1)
End With
NextCode:
GetFolder = vItem
Set fldr = Nothing
End Function
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range
Dim lLastCol As Long, lLastRow As Long
On Error Resume Next
With wrkSht
If Col = 0 Then
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
Else
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
End If
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
End With
On Error GoTo 0
End Function
Edit:
I've updated the code to include the other requirements and moved finding the last cell to within the loop so it actually works.
Note:
Mid(sFileName, InStr(sFileName, "1010EL") - 3, 3) - this code will throw an error if the text doesn't contain 1010EL. Add a check that InStr(sFileName, "1010EL") <> 0 before letting that line execute.
I have this code that browse all file types in VBA. It's already working but my what I want to do now is to delete the item in the array if it is one of the blocked file types.
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."
file = Application.GetOpenFilename(MultiSelect:=True, Title:="Select the files you want to zip")
If IsArray(file) = True Then
'Create empty Zip File
ReDim Data(1 To UBound(file) + 1, 1 To 1)
efCount = Empty
' filter the list
For j = LBound(file) To UBound(file)
ext = LCase(Mid(file(j), InStrRev(file(j), ".")))
If InStr(1, exts, ext & ".") = 0 Then ' if not blacklisted
count = count + 1
Data(count, 1) = file(j)
Else
ReDim Preserve excludedFile(efCount)
excludedFile(efCount) = Dir(file(j))
efCount = efCount + 1
file(j - 1) = file(j) 'Ive tried this and other ways bu is not working
found = True
End If
Next
Thanks for the help.
you could go like this
Dim file As Variant
Dim efCount As Long, j As Long, count As Long
Dim ext As String
Dim found As Boolean
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."
file = Application.GetOpenFilename(MultiSelect:=True, Title:="Select the files you want to zip")
If IsArray(file) = True Then
'Create empty Zip File
ReDim Data(1 To UBound(file))
ReDim excludedFile(1 To UBound(file))
efCount = 0
' filter the list
For j = LBound(file) To UBound(file)
ext = LCase(Mid(file(j), InStrRev(file(j), ".")))
If InStr(1, exts, ext & ".") = 0 Then ' if not blacklisted
count = count + 1
Data(count) = file(j)
Else
excludedFile(efCount + 1) = Dir(file(j))
efCount = efCount + 1
End If
Next
found = efCount > 0
End If
ReDim Preserve Data(1 To count)
ReDim Preserve excludedFile(1 To efCount)
file = Data
You can use function to delete particular value from array. Put this into your project:
Function DeleteElement(x As String, ByRef List() As String) ' As String
Dim i As Integer, el As Integer
Dim Result() As String
ReDim Result(UBound(List) - 1)
For i = 0 To UBound(List)
If x = List(i) Then
el = i
Exit For
End If
Next i
For i = 0 To UBound(Result)
If i < el Then
Result(i) = List(i)
Else
Result(i) = List(i + 1)
End If
Next i
DeleteElement = Result
End Function
You can use it like here:
Sub test2()
Dim arr1(3) As String
arr1(0) = "A"
arr1(1) = "B"
arr1(2) = "C"
arr1(3) = "D"
arr2 = DeleteElement("B", arr1)
End Sub
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