求助大神们，能进行文件分类储存的excel

li937476525

ooluckydog 发表于 2024-5-4 09:46

而且如果文件夹内有多余文件（多余文件指的是没写在表格内的文件），怎们将多余文件跳过？

ooluckydog

修改如下

山海风云轩

厉害厉害   

limonet

关键字：item

limonet

Sub limonet()
    Dim Dic As Object, i%, S$, Path$
    Set Dic = CreateObject("scripting.dictionary")
    For i = 3 To Range("A" & Rows.Count).End(xlUp).Row
        Dic(Cells(i, "D").Value) = Dic(Cells(i, "D").Value) & "," & Cells(i, "A").Value & ".txt"
    Next i
    Set WSHShell = CreateObject("WScript.Shell")
    WSHShell.CurrentDirectory = ThisWorkbook.Path
    WSHShell.Run "Powershell foreach ($S in ('" & Join(Dic.keys(), "','") & "')) { MD $S}", 0, True
    For i = 0 To Dic.Count - 1
        WSHShell.Run "Powershell Move-item " & Mid(Dic.items()(i), 2) & " .\" & Dic.keys()(i), 0, True
    Next i
End Sub

limonet

Sub limonet()
    Dim Dic As Object, WSHShell As Object, i%
    Set Dic = CreateObject("scripting.dictionary")
    For i = 3 To Range("A" & Rows.Count).End(xlUp).Row
        Dic(Cells(i, "D").Value) = Dic(Cells(i, "D").Value) & "," & Cells(i, "A").Value & ".txt"
    Next i
    Set WSHShell = CreateObject("WScript.Shell")
    WSHShell.CurrentDirectory = ThisWorkbook.Path
    WSHShell.Run "Powershell foreach ($S in ('" & Join(Dic.keys(), "','") & "')) { MD $S}", 0, True
    For i = 0 To Dic.Count - 1
        WSHShell.Run "Powershell Move-item " & Mid(Dic.items()(i), 2) & " .\" & Dic.keys()(i), 0
    Next i
End Sub

xlqsxl

vba代码看着头晕
我的工具可以非常方便的解决你的问题。
https://club.excelhome.net/threa ... tml?_dsign=e20fcbc2

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024.5.4
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     p = ThisWorkbook.Path & ""
   
7.     With sh
   
8.         r = .Cells(Rows.Count, 1).End(3).Row
   
9.         For i = 3 To r
   
10.             s = .Cells(i, 4): ss = .Cells(i, 1)
    
11.             If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
12.             d(s)(ss) = ""
    
13.         Next
    
14.     End With
    
15.     For Each k In d.keys
    
16.         p1 = p & k & ""
    
17.         If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
18.         For Each kk In d(k).keys
    
19.             For Each f In fso.GetFolder(p).Files
    
20.                 If f.Name Like "*.txt" Then
    
21.                     fn = fso.GetBaseName(f)
    
22.                     If fn = kk Then
    
23.                         fso.MoveFile f, p1
    
24.                     End If
    
25.                 End If
    
26.             Next f
    
27.         Next
    
28.     Next
    
29.     Application.ScreenUpdating = True
    
30.     Set d = Nothing
    
31.     MsgBox "OK！"
    
32. End Sub
    

复制代码

1sdffg

ykcbf1100 发表于 2024-5-4 20:18
附件供参考。。。

大神我也需要这个，名称能否模糊关键词定义，有时候名称不是唯一的，