Excel VBA：用户单击单元格时创建文件夹

Question

我正在使用此vba代码在用户点击单元格时创建一个文件夹。它从单元格值中提取新文件夹名称。这工作正常，但现在我想尝试做的是创建一个只有今天的日期和年份的父文件夹。

所以我们想在我们的目录中创建两个新文件夹。 我们的目录是

"Z:\Files\Storage\"

我们希望首先创建一个文件夹，从今天开始，今天是一个月和一年，如此

Aug 2014

然后我们要在2014年8月的文件夹中创建第二个文件夹，其值在我的单元格中，让我们说这个叫做

medical

我们应该有一个如下所示的目录：

＆＃34; Z：\ Files \ Storage \ Aug 2014 \ medical＆＃34;

这是我尝试过的事情

If Target.Column = Range("C" & ActiveCell.Row).Column Then
  If Target.Row > 7 Then

'Variable definations
Dim FolderListRange As Range
Dim FolderRange As Variant
Dim FolderName As String
Dim ParentFolderPath As String

On Error GoTo Handle
    ' Set the Folder where the individual folders should be created
    ParentFolderPath = "\\UKSH000-FILE06\purchasing\New Supplier Set-Ups"


    Set FolderListRange = Date & Range("A" & ActiveCell.Row).SpecialCells(xlCellTypeConstants)

    For Each FolderRange In FolderListRange

        FolderName = ParentFolderPath & "\" & Date & FolderRange.Range("A" & ActiveCell.Row)

        If FileSystem.Dir(FolderName) = vbNullString Then
            FileSystem.MkDir FolderName
        End If


Continue:
    Next

Handle:
  End If
  End If

它没有创建文件夹有人可以告诉我哪里出错了吗？

Answer 1

从我的观点来看，您的错误位于以下行：

Set FolderListRange = Date & Range("A" & ActiveCell.Row).SpecialCells(xlCellTypeConstants)

范围和日期不是兼容类型。

Answer 2

我总是使用Microsoft Scripting Runtime对象库完成任何文件服务器操作。

使用Tools \ References：

添加此库

然后创建FileSystemObject并使用CreateFolder方法。

<强> ----------------- EDIT --------------------- < / p>

我假设您正在将文件夹名称值正确输入到用于创建文件夹的代码中。如果您在创建文件夹代码时遇到问题，请尝试替换以下代码：

    If FileSystem.Dir(FolderName) = vbNullString Then
        FileSystem.MkDir FolderName
    End If

有了这个：

'Variable definations
Dim FolderListRange As Range
...

Dim oFSO As Scripting.FileSystemObject    'New Line
Set oFSO = New FileSystemObject           'New Line

...

   For Each FolderRange In FolderListRange
        FolderName = ParentFolderPath & "\" & Date & FolderRange.Range("A" & ActiveCell.Row)    

        If Not oFSO.FolderExists(FolderName) Then    'New Line
            oFSO.CreateFolder (FolderName)           'New Line 
        End If                                       'New Line