刪除數組中的目錄

Question

我有這個代碼獲取所有文件類型。

Dim file as variant 
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , True) 

然後我必須將它打印在工作表上的單元格中。

​​

但我想要的是首先檢查數組的內容。如果數組有這種文件類型，那麼我必須在數組列表中將其刪除。之後，會彈出一條消息，指出這些文件已被刪除。

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", "|") 

我只是不知道我必須從哪裏開始。我發現了一點點相同的問題here in this post，但我無法理解它。謝謝！

Answer 1

一種方法是檢查擴展它沒有出現在黑名單與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 

Answer 2

您可以使用RegExp和varaint陣列要做到這一點很快

此代碼查找路徑...點延伸端線所以它比當前的陣列更強大的可基於刪除文件路徑名，而不是文件類型

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