查找目录，不存在时创建
Finding a directory, creating it when it doesn't exist
我正在尝试在 excel 中创建一个宏，它会删除工作区中的所有信息并创建一个新文件（一个用于新一周的信息）。该任务对我来说似乎非常简单，但出于某种原因，我的目录发现和代码创建部分返回了我添加的 "something is wrong" 消息框，以指示满足 none 条件。我检查了声明中目录的拼写和位置，一切似乎都是正确的。我只需要一双全新的眼睛，因为我确定我现在遗漏了一些明显的东西。
Sub DerpDate()
'--------------------------------------------------------------------------------------------------
'Subroutine that creates necessary directories, places new workbook in those directories and clears
'out old data before terminating
'--------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------
' Declarations
'--------------------------------------------------------------------------------------------------
Dim NxtWk As Range, YrFind As Range, MonFind As Range, MonName As Range, _
LngName As String, DerpName As String, DelProd As Range, DelMold As Range, ProdSheet As Sheets, _
MoldSheet As Sheets, WindSheets As Sheets
Set NxtWk = Sheets("Data").Range("B53")
Set YrFind = Sheets("Data").Range("C53")
Set MonFind = Sheets("Data").Range("D53")
Set MonName = Sheets("Data").Range("E53")
LngName = MonFind.Value & "-" & MonName.Value & "-" & YrFind.Value
DerpName = "\Jupiter\Production Production Schedules\"
'Production Ranges
Set DelProd = Application.Union( _
Sheets("Production Schedule").Range("H5:AB9"), Sheets("Production Schedule").Range("H15:AB23"), _
Sheets("Production Schedule").Range("H29:AB30"), Sheets("Production Schedule").Range("H36:AB39"), _
Sheets("Production Schedule").Range("H45:AB54"), Sheets("Production Schedule").Range("H60:AB62"), _
Sheets("Production Schedule").Range("H68:AB73"), Sheets("Production Schedule").Range("H79:AB84"), _
Sheets("Production Schedule").Range("H90:AB94"), Sheets("Production Schedule").Range("H100:AB101"), _
Sheets("Production Schedule").Range("H107:AB112"), Sheets("Production Schedule").Range("H118:AB119"), _
Sheets("Production Schedule").Range("H125:AB126"), Sheets("Production Schedule").Range("H132:AB133"), _
Sheets("Production Schedule").Range("H139:AB140"), Sheets("Production Schedule").Range("H146:AB147"), _
Sheets("Production Schedule").Range("H153:AB156"), Sheets("Production Schedule").Range("H162:AB166"), _
Sheets("Production Schedule").Range("H172:AB175"), Sheets("Production Schedule").Range("H181:AB185"), _
Sheets("Production Schedule").Range("H186:AB186"), Sheets("Production Schedule").Range("H192:AB193"))
'Molding Ranges
Set DelMold = Application.Union( _
Sheets("Molders").Range("B5:W8"), Sheets("Molders").Range("B14:W20"), _
Sheets("Molders").Range("B26:W31"), Sheets("Molders").Range("B37:W38"), Sheets("Molders").Range("B44:W45"), _
Sheets("Molders").Range("B51:W54"), Sheets("Molders").Range("B60:W63"), Sheets("Molders").Range("B69:W72"), _
Sheets("Molders").Range("C78:W93"))
'Winding Ranges
Set DelWind = Application.Union( _
Sheets("Winders").Range("H5:AB6"), Sheets("Winders").Range("H8:AB9"), Sheets("Winders").Range("H11:AB12"), _
Sheets("Winders").Range("H14:AB15"), Sheets("Winders").Range("H17:AB18"), Sheets("Winders").Range("H20:AB21"), _
Sheets("Winders").Range("H23:AB24"), Sheets("Winders").Range("H26:AB27"), Sheets("Winders").Range("H29:AB30"), _
Sheets("Winders").Range("H32:AB33"), Sheets("Winders").Range("H35:AB36"), Sheets("Winders").Range("H38:AB39"), _
Sheets("Winders").Range("H41:AB42"), Sheets("Winders").Range("H44:AB45"), Sheets("Winders").Range("H47:AB48"), _
Sheets("Winders").Range("H50:AB51"), Sheets("Winders").Range("H53:AB54"))
'--------------------------------------------------------------------------------------------------
'Booleans to determine what (if any) directories need to be created before a new workbook can be
'created
'--------------------------------------------------------------------------------------------------
'See if the Year AND Month folder exist yet--save the new spreadsheet
If Dir(DerpName & YrFind.Value & "\" & LngName) <> "" Then
ActiveWorkbook.SaveAs Filename:=DerpName & YrFind.Value & "\" & LngName & "\" & NxtWk.Value & ".xlsm"
'If the Year AND Month Folder don't exist, see if just the Year folder does--create Month folder
'and save the new spreadsheet in it
ElseIf Dir(DerpName & YrFind.Value) <> "" Then
MkDir (DerpName & YrFind.Value & "\" & LngName)
ActiveWorkbook.SaveAs Filename:=DerpName & YrFind.Value & "\" & LngName & "\" & NxtWk.Value & ".xlsm"
'If the Year and Month Folder don't exist, create Year and Month folder and save the
'new spreadsheet in it
ElseIf Dir(DerpName) <> "" Then
MkDir (DerpName & YrFind.Value)
MkDir (DerpName & YrFind & "\" & LngName)
ActiveWorkbook.SaveAs Filename:=DerpName & YrFind.Value & "\" & LngName & "\" & NxtWk.Value & ".xlsm"
Else
MsgBox ("Something is wrong with the file location operation in the DerpDate Subroutine")
End If
'--------------------------------------------------------------------------------------------------
'Portion of the sub that removes old data from the new workbook
'--------------------------------------------------------------------------------------------------
DelProd.ClearContents
DelMold.ClearContents
DelWind.ClearContents
End Sub
感谢您提供的任何帮助！
编辑：我做了一些改动，已经解决了原来的问题。显示更改后，我返回 Path/File 访问错误 (75)。
Dim NxtWk As Range, YrFind As Range, MonFind As Range, MonName As Range, _
LngName As String, DerpName As String, DelProd As Range, DelMold As Range, ProdSheet As Sheets, _
MoldSheet As Sheets, WindSheets As Sheets, MonDig As Range, DayDig As Range, FName As String
Set NxtWk = Sheets("Data").Range("B53")
Set YrFind = Sheets("Data").Range("C53")
Set MonFind = Sheets("Data").Range("D53")
Set MonName = Sheets("Data").Range("E53")
LngName = MonFind.Value & "-" & MonName.Value & "-" & YrFind.Value
DerpName = "\Jupiter\ProductionSchedule\" & "2 Production Schedules"
'DerpName = "C:\user\dwallace\desktop"
Set MonDig = Sheets("Data").Range("B59")
Set DayDig = Sheets("Data").Range("C59")
FName = MonDig.Value & "-" & DayDig.Value & "-" & YrFind.Value
YrFold = YrFind.Value
'Production Ranges
Set DelProd = Application.Union( _
Sheets("Production Schedule").Range("H5:AB9"), Sheets("Production Schedule").Range("H15:AB23"), _
Sheets("Production Schedule").Range("H29:AB30"), Sheets("Production Schedule").Range("H36:AB39"), _
Sheets("Production Schedule").Range("H45:AB54"), Sheets("Production Schedule").Range("H60:AB62"), _
Sheets("Production Schedule").Range("H68:AB73"), Sheets("Production Schedule").Range("H79:AB84"), _
Sheets("Production Schedule").Range("H90:AB94"), Sheets("Production Schedule").Range("H100:AB101"), _
Sheets("Production Schedule").Range("H107:AB112"), Sheets("Production Schedule").Range("H118:AB119"), _
Sheets("Production Schedule").Range("H125:AB126"), Sheets("Production Schedule").Range("H132:AB133"), _
Sheets("Production Schedule").Range("H139:AB140"), Sheets("Production Schedule").Range("H146:AB147"), _
Sheets("Production Schedule").Range("H153:AB156"), Sheets("Production Schedule").Range("H162:AB166"), _
Sheets("Production Schedule").Range("H172:AB175"), Sheets("Production Schedule").Range("H181:AB185"), _
Sheets("Production Schedule").Range("H186:AB186"), Sheets("Production Schedule").Range("H192:AB193"))
'Molding Ranges
Set DelMold = Application.Union( _
Sheets("Molders").Range("B5:W8"), Sheets("Molders").Range("B14:W20"), _
Sheets("Molders").Range("B26:W31"), Sheets("Molders").Range("B37:W38"), Sheets("Molders").Range("B44:W45"), _
Sheets("Molders").Range("B51:W54"), Sheets("Molders").Range("B60:W63"), Sheets("Molders").Range("B69:W72"), _
Sheets("Molders").Range("C78:W93"))
'Winding Ranges
Set DelWind = Application.Union( _
Sheets("Winders").Range("H5:AB6"), Sheets("Winders").Range("H8:AB9"), Sheets("Winders").Range("H11:AB12"), _
Sheets("Winders").Range("H14:AB15"), Sheets("Winders").Range("H17:AB18"), Sheets("Winders").Range("H20:AB21"), _
Sheets("Winders").Range("H23:AB24"), Sheets("Winders").Range("H26:AB27"), Sheets("Winders").Range("H29:AB30"), _
Sheets("Winders").Range("H32:AB33"), Sheets("Winders").Range("H35:AB36"), Sheets("Winders").Range("H38:AB39"), _
Sheets("Winders").Range("H41:AB42"), Sheets("Winders").Range("H44:AB45"), Sheets("Winders").Range("H47:AB48"), _
Sheets("Winders").Range("H50:AB51"), Sheets("Winders").Range("H53:AB54"))
'--------------------------------------------------------------------------------------------------
'Booleans to determine what (if any) directories need to be created before a new workbook can be
'created
'--------------------------------------------------------------------------------------------------
ActiveWorkbook.Save
'See if a year directory exists. If it doesn't, create it, then create the month directory, then
'save the file.
If Len(Dir(DerpName & "\" & YrFold)) = 0 Then
MkDir (DerpName & "\" & YrFold)
MkDir (DerpName & "\" & YrFold & "\" & LngName)
ActiveWorkbook.SaveAs Filename:=DerpName & "\" & YrFold & "\" & LngName & "\" & FName & ".xlsm"
'Assuming the Year directory exists, see if the third one (Month) exists. If it doesnt, create it and
'save the file
ElseIf Len(Dir(DerpName & "\" & YrFind & "\" & LngName)) = 0 Then
MkDir DerpName & "\" & YrFold & "\" & LngName
ActiveWorkbook.SaveAs Filename:=DerpName & "\" & YrFold & "\" & LngName & "\" & FName & ".xlsm"
'Assuming all necessary directories already exist, save the file
Else
ActiveWorkbook.SaveAs Filename:=DerpName & "\" & YrFold & "\" & LngName & "\" & FName & ".xlsm"
End If
'--------------------------------------------------------------------------------------------------
'Portion of the sub that removes old data from the new workbook
'--------------------------------------------------------------------------------------------------
DelProd.ClearContents
DelMold.ClearContents
DelWind.ClearContents
End Sub
我唯一能想到的是，这是因为我正在尝试更改共享网络目录，但我没有看到某个用户设置。
对于遇到此问题的任何人，我通过一些基于主题的 google 搜索解决了这个问题。 MkDir 不太喜欢 UNC 文件路径。因此，无论我尝试如何格式化和连接都行不通。为了使用 UNC 路径的网络位置执行相同的工作，您需要一个单独的 API 函数。我在这里找到了一篇很棒的文章：
http://www.devhut.net/2011/09/15/vba-create-directory-structurecreate-multiple-directories/
只需将 API 放在单独的模块中，然后在宏中使用 UNC 文件路径调用它。 API:
Public Sub MakeFullDir(strPath As String)
If Right(strPath, 1) <> "\" Then strPath = strPath & "\" 'Optional depending upon intent
MakeSureDirectoryPathExists strPath
End Sub
宏示例：
Sub Example()
Dim filepath As String
filepath = "\Server\Directory\SubDirectory\FolderYouWantToCreate"
Call MakeFullDir(filepath)
End Sub
API 实际上取代了 Boolean 和 MkDir，因为它执行这两个功能。
希望这对某人有所帮助！
我正在尝试在 excel 中创建一个宏，它会删除工作区中的所有信息并创建一个新文件（一个用于新一周的信息）。该任务对我来说似乎非常简单，但出于某种原因，我的目录发现和代码创建部分返回了我添加的 "something is wrong" 消息框，以指示满足 none 条件。我检查了声明中目录的拼写和位置，一切似乎都是正确的。我只需要一双全新的眼睛，因为我确定我现在遗漏了一些明显的东西。
Sub DerpDate()
'--------------------------------------------------------------------------------------------------
'Subroutine that creates necessary directories, places new workbook in those directories and clears
'out old data before terminating
'--------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------
' Declarations
'--------------------------------------------------------------------------------------------------
Dim NxtWk As Range, YrFind As Range, MonFind As Range, MonName As Range, _
LngName As String, DerpName As String, DelProd As Range, DelMold As Range, ProdSheet As Sheets, _
MoldSheet As Sheets, WindSheets As Sheets
Set NxtWk = Sheets("Data").Range("B53")
Set YrFind = Sheets("Data").Range("C53")
Set MonFind = Sheets("Data").Range("D53")
Set MonName = Sheets("Data").Range("E53")
LngName = MonFind.Value & "-" & MonName.Value & "-" & YrFind.Value
DerpName = "\Jupiter\Production Production Schedules\"
'Production Ranges
Set DelProd = Application.Union( _
Sheets("Production Schedule").Range("H5:AB9"), Sheets("Production Schedule").Range("H15:AB23"), _
Sheets("Production Schedule").Range("H29:AB30"), Sheets("Production Schedule").Range("H36:AB39"), _
Sheets("Production Schedule").Range("H45:AB54"), Sheets("Production Schedule").Range("H60:AB62"), _
Sheets("Production Schedule").Range("H68:AB73"), Sheets("Production Schedule").Range("H79:AB84"), _
Sheets("Production Schedule").Range("H90:AB94"), Sheets("Production Schedule").Range("H100:AB101"), _
Sheets("Production Schedule").Range("H107:AB112"), Sheets("Production Schedule").Range("H118:AB119"), _
Sheets("Production Schedule").Range("H125:AB126"), Sheets("Production Schedule").Range("H132:AB133"), _
Sheets("Production Schedule").Range("H139:AB140"), Sheets("Production Schedule").Range("H146:AB147"), _
Sheets("Production Schedule").Range("H153:AB156"), Sheets("Production Schedule").Range("H162:AB166"), _
Sheets("Production Schedule").Range("H172:AB175"), Sheets("Production Schedule").Range("H181:AB185"), _
Sheets("Production Schedule").Range("H186:AB186"), Sheets("Production Schedule").Range("H192:AB193"))
'Molding Ranges
Set DelMold = Application.Union( _
Sheets("Molders").Range("B5:W8"), Sheets("Molders").Range("B14:W20"), _
Sheets("Molders").Range("B26:W31"), Sheets("Molders").Range("B37:W38"), Sheets("Molders").Range("B44:W45"), _
Sheets("Molders").Range("B51:W54"), Sheets("Molders").Range("B60:W63"), Sheets("Molders").Range("B69:W72"), _
Sheets("Molders").Range("C78:W93"))
'Winding Ranges
Set DelWind = Application.Union( _
Sheets("Winders").Range("H5:AB6"), Sheets("Winders").Range("H8:AB9"), Sheets("Winders").Range("H11:AB12"), _
Sheets("Winders").Range("H14:AB15"), Sheets("Winders").Range("H17:AB18"), Sheets("Winders").Range("H20:AB21"), _
Sheets("Winders").Range("H23:AB24"), Sheets("Winders").Range("H26:AB27"), Sheets("Winders").Range("H29:AB30"), _
Sheets("Winders").Range("H32:AB33"), Sheets("Winders").Range("H35:AB36"), Sheets("Winders").Range("H38:AB39"), _
Sheets("Winders").Range("H41:AB42"), Sheets("Winders").Range("H44:AB45"), Sheets("Winders").Range("H47:AB48"), _
Sheets("Winders").Range("H50:AB51"), Sheets("Winders").Range("H53:AB54"))
'--------------------------------------------------------------------------------------------------
'Booleans to determine what (if any) directories need to be created before a new workbook can be
'created
'--------------------------------------------------------------------------------------------------
'See if the Year AND Month folder exist yet--save the new spreadsheet
If Dir(DerpName & YrFind.Value & "\" & LngName) <> "" Then
ActiveWorkbook.SaveAs Filename:=DerpName & YrFind.Value & "\" & LngName & "\" & NxtWk.Value & ".xlsm"
'If the Year AND Month Folder don't exist, see if just the Year folder does--create Month folder
'and save the new spreadsheet in it
ElseIf Dir(DerpName & YrFind.Value) <> "" Then
MkDir (DerpName & YrFind.Value & "\" & LngName)
ActiveWorkbook.SaveAs Filename:=DerpName & YrFind.Value & "\" & LngName & "\" & NxtWk.Value & ".xlsm"
'If the Year and Month Folder don't exist, create Year and Month folder and save the
'new spreadsheet in it
ElseIf Dir(DerpName) <> "" Then
MkDir (DerpName & YrFind.Value)
MkDir (DerpName & YrFind & "\" & LngName)
ActiveWorkbook.SaveAs Filename:=DerpName & YrFind.Value & "\" & LngName & "\" & NxtWk.Value & ".xlsm"
Else
MsgBox ("Something is wrong with the file location operation in the DerpDate Subroutine")
End If
'--------------------------------------------------------------------------------------------------
'Portion of the sub that removes old data from the new workbook
'--------------------------------------------------------------------------------------------------
DelProd.ClearContents
DelMold.ClearContents
DelWind.ClearContents
End Sub
感谢您提供的任何帮助！
编辑：我做了一些改动，已经解决了原来的问题。显示更改后，我返回 Path/File 访问错误 (75)。
Dim NxtWk As Range, YrFind As Range, MonFind As Range, MonName As Range, _
LngName As String, DerpName As String, DelProd As Range, DelMold As Range, ProdSheet As Sheets, _
MoldSheet As Sheets, WindSheets As Sheets, MonDig As Range, DayDig As Range, FName As String
Set NxtWk = Sheets("Data").Range("B53")
Set YrFind = Sheets("Data").Range("C53")
Set MonFind = Sheets("Data").Range("D53")
Set MonName = Sheets("Data").Range("E53")
LngName = MonFind.Value & "-" & MonName.Value & "-" & YrFind.Value
DerpName = "\Jupiter\ProductionSchedule\" & "2 Production Schedules"
'DerpName = "C:\user\dwallace\desktop"
Set MonDig = Sheets("Data").Range("B59")
Set DayDig = Sheets("Data").Range("C59")
FName = MonDig.Value & "-" & DayDig.Value & "-" & YrFind.Value
YrFold = YrFind.Value
'Production Ranges
Set DelProd = Application.Union( _
Sheets("Production Schedule").Range("H5:AB9"), Sheets("Production Schedule").Range("H15:AB23"), _
Sheets("Production Schedule").Range("H29:AB30"), Sheets("Production Schedule").Range("H36:AB39"), _
Sheets("Production Schedule").Range("H45:AB54"), Sheets("Production Schedule").Range("H60:AB62"), _
Sheets("Production Schedule").Range("H68:AB73"), Sheets("Production Schedule").Range("H79:AB84"), _
Sheets("Production Schedule").Range("H90:AB94"), Sheets("Production Schedule").Range("H100:AB101"), _
Sheets("Production Schedule").Range("H107:AB112"), Sheets("Production Schedule").Range("H118:AB119"), _
Sheets("Production Schedule").Range("H125:AB126"), Sheets("Production Schedule").Range("H132:AB133"), _
Sheets("Production Schedule").Range("H139:AB140"), Sheets("Production Schedule").Range("H146:AB147"), _
Sheets("Production Schedule").Range("H153:AB156"), Sheets("Production Schedule").Range("H162:AB166"), _
Sheets("Production Schedule").Range("H172:AB175"), Sheets("Production Schedule").Range("H181:AB185"), _
Sheets("Production Schedule").Range("H186:AB186"), Sheets("Production Schedule").Range("H192:AB193"))
'Molding Ranges
Set DelMold = Application.Union( _
Sheets("Molders").Range("B5:W8"), Sheets("Molders").Range("B14:W20"), _
Sheets("Molders").Range("B26:W31"), Sheets("Molders").Range("B37:W38"), Sheets("Molders").Range("B44:W45"), _
Sheets("Molders").Range("B51:W54"), Sheets("Molders").Range("B60:W63"), Sheets("Molders").Range("B69:W72"), _
Sheets("Molders").Range("C78:W93"))
'Winding Ranges
Set DelWind = Application.Union( _
Sheets("Winders").Range("H5:AB6"), Sheets("Winders").Range("H8:AB9"), Sheets("Winders").Range("H11:AB12"), _
Sheets("Winders").Range("H14:AB15"), Sheets("Winders").Range("H17:AB18"), Sheets("Winders").Range("H20:AB21"), _
Sheets("Winders").Range("H23:AB24"), Sheets("Winders").Range("H26:AB27"), Sheets("Winders").Range("H29:AB30"), _
Sheets("Winders").Range("H32:AB33"), Sheets("Winders").Range("H35:AB36"), Sheets("Winders").Range("H38:AB39"), _
Sheets("Winders").Range("H41:AB42"), Sheets("Winders").Range("H44:AB45"), Sheets("Winders").Range("H47:AB48"), _
Sheets("Winders").Range("H50:AB51"), Sheets("Winders").Range("H53:AB54"))
'--------------------------------------------------------------------------------------------------
'Booleans to determine what (if any) directories need to be created before a new workbook can be
'created
'--------------------------------------------------------------------------------------------------
ActiveWorkbook.Save
'See if a year directory exists. If it doesn't, create it, then create the month directory, then
'save the file.
If Len(Dir(DerpName & "\" & YrFold)) = 0 Then
MkDir (DerpName & "\" & YrFold)
MkDir (DerpName & "\" & YrFold & "\" & LngName)
ActiveWorkbook.SaveAs Filename:=DerpName & "\" & YrFold & "\" & LngName & "\" & FName & ".xlsm"
'Assuming the Year directory exists, see if the third one (Month) exists. If it doesnt, create it and
'save the file
ElseIf Len(Dir(DerpName & "\" & YrFind & "\" & LngName)) = 0 Then
MkDir DerpName & "\" & YrFold & "\" & LngName
ActiveWorkbook.SaveAs Filename:=DerpName & "\" & YrFold & "\" & LngName & "\" & FName & ".xlsm"
'Assuming all necessary directories already exist, save the file
Else
ActiveWorkbook.SaveAs Filename:=DerpName & "\" & YrFold & "\" & LngName & "\" & FName & ".xlsm"
End If
'--------------------------------------------------------------------------------------------------
'Portion of the sub that removes old data from the new workbook
'--------------------------------------------------------------------------------------------------
DelProd.ClearContents
DelMold.ClearContents
DelWind.ClearContents
End Sub
我唯一能想到的是，这是因为我正在尝试更改共享网络目录，但我没有看到某个用户设置。
对于遇到此问题的任何人，我通过一些基于主题的 google 搜索解决了这个问题。 MkDir 不太喜欢 UNC 文件路径。因此，无论我尝试如何格式化和连接都行不通。为了使用 UNC 路径的网络位置执行相同的工作，您需要一个单独的 API 函数。我在这里找到了一篇很棒的文章：
http://www.devhut.net/2011/09/15/vba-create-directory-structurecreate-multiple-directories/
只需将 API 放在单独的模块中，然后在宏中使用 UNC 文件路径调用它。 API:
Public Sub MakeFullDir(strPath As String)
If Right(strPath, 1) <> "\" Then strPath = strPath & "\" 'Optional depending upon intent
MakeSureDirectoryPathExists strPath
End Sub
宏示例：
Sub Example()
Dim filepath As String
filepath = "\Server\Directory\SubDirectory\FolderYouWantToCreate"
Call MakeFullDir(filepath)
End Sub
API 实际上取代了 Boolean 和 MkDir，因为它执行这两个功能。
希望这对某人有所帮助！