Question

我有这个代码可以获取所有文件类型。

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

但我想要的是先检查数组的内容。如果数组具有此文件类型，那么我必须在arraylist中删除它。之后，将弹出一条消息，表明此文件已被删除。

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

您可以使用RegExp和varaint数组快速执行此操作

此代码查找 path ... dot extension end string ，因此它比您当前的数组更强大，可能会根据路径名而不是文件类型删除文件

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

Answer 2

一种方法是使用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

删除数组中的目录

2 个答案: