相同前辍的工作薄放到一个文件夹中

春日秋水

以“-”前的名称创建文件夹，并将相对应的工作薄放到相应的文件夹中。
求助1.zip (59.4 KB, 下载次数: 5)

2024-7-17 21:33 上传

点击文件名下载附件

非常感谢

ykcbf1100

问题挺多。你上个求助帖看了吗？怎么没有回复？

春日秋水

ykcbf1100 发表于 2024-7-17 21:36
问题挺多。你上个求助帖看了吗？怎么没有回复？

学习中，有些问题还希望指导。非常感谢

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.17  文件移动
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Set ws = ThisWorkbook
   
7.     p = ws.Path & ""
   
8.     For Each f In fso.GetFolder(p).Files
   
9.         If f.Name Like "*.xls*" Then
   
10.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
11.                 fn = fso.GetBaseName(f)
    
12.                 s = Split(fn, "-")(0)
    
13.                 If Not d.exists(s) Then
    
14.                     d(s) = ""
    
15.                     p1 = p & s & ""
    
16.                     If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
17.                 End If
    
18.                 If d.exists(s) Then
    
19.                     fso.MoveFile f, p1
    
20.                 End If
    
21.             End If
    
22.         End If
    
23.     Next f
    
24.     Set d = Nothing
    
25.     Application.ScreenUpdating = True
    
26.     MsgBox "OK！"
    
27. End Sub
    
28. 
    

复制代码

limonet

关键字：split

limonet

数量多才有优势。
Sub limonet()
    CreateObject("wscript.shell").Run "powershell push-location " & ThisWorkbook.Path _
    & ";dir .\* -file -exclude '*.xlsm' | %{$s=$_.name.split('-')[0];if ((test-path $s) -eq $False) {md $s};move $_ $s}", 0
End Sub

quqiyuan

参与一下，巩本参考。。。

quqiyuan

代码如下，设置了如果存在相同文件名，则不移动，请留意。。。
Sub test()
    Set fso = CreateObject("scripting.filesystemobject")
    p = ThisWorkbook.Path & "\"
    For Each f In fso.getfolder(p).Files
        Debug.Print f.Name
        If InStr(f.Name, ThisWorkbook.Name) = 0 Then
            If Not fso.folderexists(p & Split(f.Name, "-")(0)) Then fso.createfolder p & Split(f.Name, "-")(0)
            If Not fso.fileexists(p & f.Name) Then
                fso.movefile p & f.Name, p & Split(f.Name, "-")(0) & "\" & f.Name
            End If
        End If
    Next
    Beep
End Sub

limonet

关键字：-ashashtable，追求效率可以用这个。