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

filtersh · 发表于 2024-4-29 10:29

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

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

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

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

3190496160 · 发表于 2024-4-29 12:09

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 · 发表于 2024-4-29 12:10

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

ykcbf1100 · 发表于 2024-4-29 14:04

附件供参考。。。

ykcbf1100 · 发表于 2024-4-29 14:05

参与一下。。。

Sub ykcbf() '//2024.4.29
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")
p = ThisWorkbook.Path & ""
' p = "e:" '//文件夹路径,实际使用时此句代替上一句
With Sheets("Sheet1")
r = .Cells(Rows.Count, "b").End(3).Row
arr = .[b1].Resize(r, 2)
End With
For i = 2 To UBound(arr)
s = Year(arr(i, 1))
ss = Month(arr(i, 1))
sss = arr(i, 2)
If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
If Not d(s).exists(ss) Then Set d(s)(ss) = CreateObject("Scripting.Dictionary")
d(s)(ss)(sss) = ""
Next
For Each k In d.keys
p1 = p & k & ""
If Not fso.FolderExists(p1) Then fso.CreateFolder p1
For Each kk In d(k).keys
p2 = p1 & kk & "月委托单"
If Not fso.FolderExists(p2) Then fso.CreateFolder p2
For Each kkk In d(k)(kk).keys
p3 = p2 & kkk & ""
If Not fso.FolderExists(p3) Then fso.CreateFolder p3
Next
Next
Next
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

570964373 · 发表于 2024-4-29 14:06

附件供参考。。。

filtersh · 发表于 2024-4-29 15:02

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

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

filtersh · 发表于 2024-4-29 15:04

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

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

filtersh · 发表于 2024-4-29 15:06

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

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

filtersh · 发表于 2024-4-29 15:09

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

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

		自动登录	找回密码
密码			免费注册

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

评分

评分