Question

我正在尝试从特定文件夹中所有文件的文件名在单个工作簿中创建多个工作表。

示例：

1）一个文件夹有4个.xlsx文件，它们的名字是：MyFile1，MyFile2，MyFile3，MyFile4

2）有一个只有默认工作表的工作簿

3）宏需要扫描文件夹中该文件夹中扩展名为.xlsx的所有文件，并将文件名存储在数组中

4）在这个例子中，只有四个文件，因此数组应该存储4个文件名

5）然后宏将创建四张纸并根据文件夹

中找到的文件名命名每张纸

我目前有以下代码示例，但有两个问题：

1）它只创建一个工作表并用第一个文件的名称重命名 - 因此循环不起作用

2）它使用文件名和扩展名（MyFile1.xlsx等）创建工作表名称 - 我只需要文件名，而不是扩展名

Sub CreateNewWorkSheet()

    'Instantiate variables
    Dim xSht As Worksheet
    Dim xNSht As Worksheet
    Dim xSUpdate As Boolean
    Dim xRow As Long
    Dim MyFile As String
    Dim Counter As Long

    On Error Resume Next

    Set xSht = ActiveWorkbook.Sheets("3rd Party")

    'Create a dynamic array variable, and then declare its initial size
    Dim DirectoryListArray() As String
    ReDim DirectoryListArray(1000)

    'Loop through all the files in the directory by using Dir$ function
    MyFile = Dir$("C:\Users\Desktop\3rd Party\Work Folder\*.*")

    'This line of code just helps the macro sun faster
    xSUpdate = Application.ScreenUpdating
    Application.ScreenUpdating = False

    For Counter = 0 To UBound(DirectoryListArray)

        DirectoryListArray(Counter) = MyFile

        'If the sheet does not exist, then create the new sheet and name it the string from index I
        If xNSht Is Nothing Then
            Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
            xNSht.Name = DirectoryListArray(Counter)
        Else

        End If

        Counter = Counter + 1

    Next Counter

    'Reset the size of the array without losing its values by using Redim Preserve
    ReDim Preserve DirectoryListArray(Counter - 1)

    xSht.AutoFilterMode = False
    xSht.Activate
    Application.ScreenUpdating = xSUpdate

End Sub

Answer 1

Sub LoopThroughFiles()
    Dim file As Variant, root As String, n As Integer

    root = "C:\TheDir"
   file = Dir(root)
   n = 0

   While (file <> "")
      If InStr(file, ".xlsx") > 0 Then
      n = n + 1

    ActiveWorkbook.Worksheets.Add

        With ActiveSheet
          'Do stuff    
          .Name = Replace(file, ".xlsx", "") 'manipulate filename string to remove .xlsx
        End With

      End If
     file = Dir
  Wend

End Sub

Answer 2

Sub test()
  Dim Filenames As Variant, strFilename As Variant, strPath As String
  Dim i As LongPtr

  strPath = "D:\myPath"
  strFilename = Dir(strPath & "\" & "*.xlsx")
  Do Until strFilename = ""
    Filenames = Filenames & "|" & strFilename
    strFilename = Dir
  Loop

  Filenames = Mid(Filenames, 2)
  Filenames = Split(Filenames, "|")  ' <- all .xlsx filenames in this array

  For i = LBound(Filenames) To UBound(Filenames)
    with Worksheets.Add 
      .name = Left(Filenames(i), Len(Filenames(i)) - 5)
    end with
  Next i

End Sub

VBA - 基于文件名创建工作表

2 个答案: