根据单元格中的日期和编号自动生成文件夹

filtersh

B列单元格是日期，C列单元格是编号

根据日期的月份生成子文件夹1月委托单，在1月委托单下根据编号生成文件夹名称
根目录根据该工作表存放的位置生成，例：该工作表存放在E盘

则根据B2和C2生成的文件夹位置：E:\2024\1月委托单\Q201015D01
          B3和C3生成的文件夹位置：E:\2024\1月委托单\Q20230718D01
依次类推。

之前填写的已经手动建过文件夹了，以后每次填写新的日期编号后，根据填写的日期编号在对应的位置生成新的文件夹，求大神帮忙。谢谢。

3190496160

Sub 新建文件夹()
Dim fso
myPath = ThisWorkbook.Path & "\"
Set fso = CreateObject("Scripting.FileSystemObject")
With ActiveSheet
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    If r < 2 Then MsgBox "数据源为空！": End
    ar = .Range("b1:c" & r)
End With
For i = 2 To UBound(ar)
    If ar(i, 1) <> "" And ar(i, 2) <> "" Then
        If IsDate(ar(i, 1)) Then
            nf = Year(ar(i, 1))
            yf = Month(ar(i, 1)) & "月委托单"
            nfwjj = myPath & nf
            If Not fso.folderexists(nfwjj) Then fso.CreateFolder nfwjj
            yfwjj = myPath & nf & "\" & yf
            If Not fso.folderexists(yfwjj) Then fso.CreateFolder yfwjj
            bhwjj = myPath & nf & "\" & yf & "\" & ar(i, 2)
            If Not fso.folderexists(bhwjj) Then fso.CreateFolder bhwjj
        End If
    End If
Next i
Set fso = Nothing
MsgBox "ok!"
End Sub

3190496160

根据日期和编号生成文件夹.rar (16.93 KB, 下载次数: 20)

2024-4-29 12:10 上传

点击文件名下载附件

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.29
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set fso = CreateObject("Scripting.FileSystemObject")
   
6.     p = ThisWorkbook.Path & ""
   
7.     '   p = "e:"   '//文件夹路径,实际使用时此句代替上一句
   
8.     With Sheets("Sheet1")
   
9.         r = .Cells(Rows.Count, "b").End(3).Row
   
10.         arr = .[b1].Resize(r, 2)
    
11.     End With
    
12.     For i = 2 To UBound(arr)
    
13.         s = Year(arr(i, 1))
    
14.         ss = Month(arr(i, 1))
    
15.         sss = arr(i, 2)
    
16.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
17.         If Not d(s).exists(ss) Then Set d(s)(ss) = CreateObject("Scripting.Dictionary")
    
18.         d(s)(ss)(sss) = ""
    
19.     Next
    
20.     For Each k In d.keys
    
21.         p1 = p & k & ""
    
22.         If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
23.         For Each kk In d(k).keys
    
24.             p2 = p1 & kk & "月委托单"
    
25.             If Not fso.FolderExists(p2) Then fso.CreateFolder p2
    
26.             For Each kkk In d(k)(kk).keys
    
27.                 p3 = p2 & kkk & ""
    
28.                 If Not fso.FolderExists(p3) Then fso.CreateFolder p3
    
29.             Next
    
30.         Next
    
31.     Next
    
32.     Set d = Nothing
    
33.     Application.ScreenUpdating = True
    
34.     MsgBox "OK！"
    
35. End Sub
    
36. 
    

复制代码

570964373

附件供参考。。。

filtersh

3190496160 发表于 2024-4-29 12:09
Sub 新建文件夹()
Dim fso
myPath = ThisWorkbook.Path & "\"

非常感谢您的回复，但是我复制了代码后出现变量未定义。

filtersh

3190496160 发表于 2024-4-29 12:10

非常感谢您，让我从手工劳动中解脱出来。

filtersh

ykcbf1100 发表于 2024-4-29 14:04
附件供参考。。。

已试用，满足需求，非常感谢。

filtersh

570964373 发表于 2024-4-29 14:06
附件供参考。。。

可以生成文件夹，但是生成稍微有点问题，所有的子文夹在2024对应的月份当中，但是执行程序后出现了2024/2025/2026/2027这样子的文件夹