[Visual Basic] 纯文本查看 复制代码
Sub test()
Dim fldr As FileDialog
Dim f, ibox, sn, f1
Dim i, i1, i2, r, i3, k1, k, lj, lj1, lj2, arr1, arr, brr, crr, drr, t, arr2, t1
Dim sPath As String
Dim oShell As Object
Dim MyName As String, folders As Object
Application.ScreenUpdating = False
'通过cmd命令，获取选取文件夹下的所有文件路径，写入sheet2中
Sheet2.Range("A:E").Clear
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
On Error GoTo ext
fldr.Show
f = fldr.SelectedItems(1)
sPath = f
f = f & "\"
ibox = "*.pdf*"
sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & f & ibox & """ /s /a /b").stdout.readall, vbCrLf)
Sheets(2).Cells(1).Resize(UBound(sn) + 1) = Application.Transpose(sn)
ext:
If Err.Number = 5 Then
MsgBox ("你点了取消")
Exit Sub
End If
'整理获取路径下的所有文件需求名
With Sheet2
i = 1
Do While .Range("A" & i) <> ""
.Range("B" & i) = Right(.Range("A" & i), Len(.Range("A" & i)) - InStrRev(.Range("A" & i), "\"))
i1 = InStr(.Range("B" & i), "-")
i2 = InStrRev(.Range("B" & i), "-")
.Range("C" & i) = Replace(Mid(.Range("B" & i), i1 + 1, i2 - i1), "-", "")
'.Range("D" & i) = Left(.Range("A" & i), InStrRev(.Range("A" & i), "\") - 1)
'.Range("D" & i) = Left(Right(.Range("D" & i), Len(.Range("D" & i)) - InStrRev(.Range("D" & i), "\")), 4)
i = i + 1
Loop
End With
'整理需要创建的文件夹名称
With Sheet1
i3 = 2
Do While .Range("A" & i3) <> ""
r = .Range("p1048576").End(xlUp).Row + 1
.Range("p" & r) = .Range("G" & i3) & "、" & .Range("H" & i3) '为了创建文件夹名称
.Range("J" & r) = .Range("G" & i3) & "、" & .Range("H" & i3) '为了后续路径判断
i3 = i3 + 1
Loop
Call quchong
'开始创建文件夹
On Error GoTo elujing
For k = 1 To .Range("P1048576").End(xlUp).Row
lj = f & .Cells(k, 16)
MkDir lj
Next
elujing:
If Err.Number = 75 Then
MsgBox ("已经建立了文件夹，请删除后重新分类")
Exit Sub
End If
'开始条件判断，移动文件进文件夹
Set arr1 = CreateObject("Scripting.FileSystemObject")
arr = Sheet1.Range("A1").CurrentRegion.Value
brr = Sheet2.Range("A1").CurrentRegion.Value
For i = 2 To UBound(arr, 1)
For j = 1 To UBound(brr, 1)
crr = arr(i, 1)
drr = brr(j, 3)
If crr = drr Then
Sheet2.Range("D" & j) = arr(i, 10)
f1 = f & Sheet2.Range("D" & j) & "\"
arr1.copyfile brr(j, 1), f1
End If
Next
Next
'判断未分类的文件，复制到外面
Set arr2 = CreateObject("Scripting.FileSystemObject")
t = 1
t1 = 1
Do While Sheet2.Range("A" & t) <> ""
If Sheet2.Range("D" & t) = "" Then
arr2.copyfile Sheet2.Range("A" & t), f
t1 = t1 + 1
End If
t = t + 1
Loop
End With
Sheet1.Range("J:Q").Delete
MsgBox ("已完成全部分类，请查看，共有" & t1 & "个PDF未分类")
Application.ScreenUpdating = True
'打开分类文件夹
Set oShell = VBA.CreateObject("shell.application")
With oShell
.Open (sPath)
End With
End Sub
Sub quchong()
Dim i, j, k, s, arr
Set s = CreateObject("Scripting.Dictionary")
arr = Range("P2").CurrentRegion
For j = 1 To UBound(arr)
If Not s.Exists(arr(j, 1)) Then
s(arr(j, 1)) = ""
End If
Next
Range("P:P").ClearContents
Range("P1").Resize(s.Count, 1) = Application.Transpose(s.Keys)
Set s = Nothing
End Sub
发表于 2022-11-23 12:09
|
发表于 2022-11-23 12:32
