删除数组中的目录
我有这个代码获取所有文件types。
Dim file as variant file = Application.GetOpenFilename("All Files, *.*", , "Select File", , True) 然后我必须把它打印在纸上的单元格中。
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
但我想要的是首先检查数组的内容。 如果数组有这种文件types，那么我必须在数组列表中将其删除。 之后，会popup一条消息，指出这些文件已被删除。
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", "|")
我只是不知道从哪里开始。 在这篇文章中 ，我发现了一些相同的问题，但是我无法理解。 谢谢！
一种方法是检查它是不是在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
您可以使用RegExp和varaint数组来快速完成此操作
此代码查找path…点扩展结束string，因此它比您当前的数组更可靠，可能会删除基于path名称而不是文件types的文件
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