Question

我有列出所选文件夹中所有文件的代码。现在，它将创建名为“文件”的新工作表。如何修改此代码，使用户每次单击按钮时都输入文件夹名称？因此，基本上情况如下：

点击按钮
选择文件夹以列出文件来自
键入将在其中列出文件的新工作表名称
代码已处理
点击按钮
选择文件夹以列出文件来自
键入将在其中列出文件的新工作表名称
代码已处理
直到世界尽头的相同行动

我已经尝试过了这一步，但是可能在输入我的代码时出现了错误：

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个字符）并且其中不包含任何非法字符（ \ / * [ ] ： ？）

Excel VBA允许用户输入新的工作表名称

1 个答案: