Excel VBA 让用户输入新工作表名称

Question

我有代码可以列出所选文件夹中的所有文件。现在它创建名为“Files”的新工作表。如何修改此代码以使用户每次单击按钮时都输入文件夹名称？所以基本上场景是这样的:

1. 点击按钮
2. 选择要列出文件的文件夹
3. 输入将在其中列出文件的新工作表名称
4. 代码已处理
5. 点击按钮
6. 选择要列出文件的文件夹
7. 输入将在其中列出文件的新工作表名称
8. 代码已处理
9. 同样的行动，直到世界末日

我已经尝试过这个，但可能在输入代码时出现错误:

Dim NewName As String 
NewName = InputBox("What Do you Want to Name the Sheet1 ?") 
Sheets("Sheet1").Name = NewName 

我尝试用以下方法修改它:

Sheets.Add.Name = NewName
        Sheets(NewName).[A1].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)

我的用于列出文件和每个文件的完整路径的代码:

Sub ListAllFilesInAllFolders()

    Dim MyPath As String, MyFolderName As String, MyFileName As String
    Dim i As Integer, F As Boolean
    Dim objShell As Object, objFolder As Object, AllFolders As Object, AllFiles As Object
    Dim MySheet As Worksheet

    On Error Resume Next

    '************************
    'Select folder
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
    If Not objFolder Is Nothing Then
        'MyPath = 
        MyPath = objFolder.self.Path & "\"
    Else
        Exit Sub

    End If
    Set objFolder = Nothing
    Set objShell = Nothing

    '************************
    'List all folders

    Set AllFolders = CreateObject("Scripting.Dictionary")
    Set AllFiles = CreateObject("Scripting.Dictionary")
    AllFolders.Add (MyPath), ""
    i = 0
    Do While i < AllFolders.Count
        Key = AllFolders.keys
        MyFolderName = Dir(Key(i), vbDirectory)
        Do While MyFolderName <> ""
            If MyFolderName <> "." And MyFolderName <> ".." Then
                If (GetAttr(Key(i) & MyFolderName) And vbDirectory) = vbDirectory Then
                    AllFolders.Add (Key(i) & MyFolderName & "\"), ""
                End If
            End If
            MyFolderName = Dir
        Loop
        i = i + 1
    Loop

    'List all files
    For Each Key In AllFolders.keys
        MyFileName = Dir(Key & "*.*")
        'MyFileName = Dir(Key & "*.PDF")    'only PDF files
        Do While MyFileName <> ""
            AllFiles.Add (Key & MyFileName), ""
            MyFileName = Dir
        Loop
    Next

    '************************
    'List all files in Files sheet

    For Each MySheet In ThisWorkbook.Worksheets
        If MySheet.Name = "Files" Then
            Sheets("Files").Cells.Delete
            F = True
            Exit For
        Else
            F = False
        End If
    Next
    If Not F Then Sheets.Add.Name = "Files"

    'Sheets("Files").[A1].Resize(AllFolders.Count, 1) = WorksheetFunction.Transpose(AllFolders.keys)
    Sheets("Files").[A1].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
    Set AllFolders = Nothing
    Set AllFiles = Nothing
End Sub

Answer 1

尝试使用

With Sheets.Add
    .Name = NewName
    .Range("A1").Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
End With

此外，无需循环测试工作表是否存在。使用错误处理代替

Dim FilesSheet as Worksheet

On Error Resume Next
Set FilesSheet = Thisworkbook.Sheets("Files")
On Error GoTo 0

If Not FilesSheet is Nothing then
    F = True
    Set FilesSheet = ThisWorkbook.Sheets.Add
    FilesSheet.Name = NewName
Else
    F = False
    FilesSheet.Cells.Delete
End If

FilesSheet.Range("A1").Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)

如果您要为最终用户创建此名称，您可能还需要内置功能来检查他们输入的 NewName 对于 Excel 工作表名称来说是否太长(>31 个字符)并且不不包含任何非法字符 (\ / * [ ] : ？)