Question

我正在处理一个宏，该宏将驱动器上当前年，月和日的文件夹中的工作簿中的标签另存为CSV文件。如果不存在任何文件夹，则宏将创建它们。此过程每周在星期一，星期二（有时是星期三）运行两次。我希望代码不仅可以查找当天的文件夹，还可以查找连续两天的文件夹，然后再创建新文件夹。目标是将在星期一，星期二和星期三创建的所有文件保存在星期一日期文件夹中。以下代码可用于创建要保存到当前日期的文件夹。我需要添加代码的帮助，以便首先查找日期为前两天的文件夹，然后，如果找不到该日期，请搜索前一天，然后，如果找不到前两个日期，请在创建索引前搜索当前日期新建文件夹。谢谢！

'Save new file to correct folder based on the current date.  If no folder exists, the formula creates its own folder.  Files are saved as CSV files.
Dim strGenericFilePath      As String: strGenericFilePath = "W:\"
Dim strYear                 As String: strYear = Year(Date) & "\"
Dim strMonth                As String: strMonth = Format(Date, "MM - ") & MonthName(Month(Date)) & "\"
Dim strDay                  As String: strDay = Format(Date, "MM-DD") & "\"
Dim strFileName             As String: strFileName = "Res-Rep Brinks_Armored Entries - " & Format(Date, "MM-DD-YYYY")

Application.DisplayAlerts = False

' Check for year folder and create if needed.
If Len(Dir(strGenericFilePath & strYear, vbDirectory)) = 0 Then
    MkDir strGenericFilePath & strYear
End If

' Check for month folder and create if needed.
If Len(Dir(strGenericFilePath & strYear & strMonth, vbDirectory)) = 0 Then
    MkDir strGenericFilePath & strYear & strMonth
End If

' Check for date folder and create if needed.
If Len(Dir(strGenericFilePath & strYear & strMonth & strDay, vbDirectory)) = 0 Then
    MkDir strGenericFilePath & strYear & strMonth & strDay
End If

' Save File
 ActiveWorkbook.SaveAs Filename:= _
 strGenericFilePath & strYear & strMonth & strDay & strFileName, _
 FileFormat:=xlCSV, CreateBackup:=False

Answer 1

这是一个可能对您有帮助的小功能：

Function MondayOfWeek(InDate As Date) As Date
    Dim DayOfWeek As Integer
    DayOfWeek = DatePart("w", InDate, vbMonday)
    MondayOfWeek = DateAdd("d", InDate, -(DayOfWeek - 1))
End Function

如果找出提供的日期是星期几并减去该数字。像这样使用它：

strDay = Format(MondayOfWeek(Date), "MM-DD") & "\"

用于将文件保存到当前日期，前一天或前两天的文件夹的宏代码

1 个答案: