如何根据第一个和最后一个文件名将100个文件复制到一个文件夹并在列表框vba中显示

Question

我正在尝试编写一段脚本，允许我从一个文件夹中复制 100 个文件，并根据第一个文件和最后一个文件名创建一个新文件夹，然后将这 100 个文件移动到该文件夹​​中。 移动这些文件后，我希望它将用户表单列表框中的文件夹显示为可点击项目。 例如，列表框中的每个项目都是一个文件夹，如果我双击文件夹名称，它将在我设置的工作表中显示文件的所有内容（100 个文件中的每一个）。

我还不能测试这段代码，过去一周我所做的只是研究并一遍又一遍地重写代码，直到我能正确理解它，然后再将其添加到程序中。所以在这个过程中肯定会出现一些或更多的错误。

我注意到的是“objFile.CopyFile Folderpath & FCount & "_" & LCount” 一段代码，它没有指定可以专门复制哪些文件。例如，我希望它从第一个文件开始并开始处理前 100 个文件，当再次执行代码时，它将从文件 101 开始并复制接下来的 100 个文件。如果有办法确保它不会继续复制前 100 个文件，那就太棒了！

Sub Main()
'====CHECK IF THERE'S 100 FILES====

    Dim filename, folderpath, path As String
    Dim count As Integer
    Dim FCount, LCount, FlagCount, IntCount As Integer
    Dim objFSO As Object
    Dim obj As Object

    FCount = 0                                        ' First File name
    LCount = 0                                        'Last file name
    count = 0                                         'file count
    FlagCount = Sheets("Flag Sheet").Range("A2").Value

    folderpath = "Work\Big Book\"                     '==================Location Of The Book
    path = folderpath & "*.xls"
    filename = Dir(path)

    Do While filename <> ""
        count = count + 1
        filename = Dir(path)
    Loop
If count < 100 Then

        '====CREATE A FOLDER FOR THE FILES====

        If FlagCount <> "" Then                       '====If there is a flag count, it will create a folder based on the last number it was used
            FCount = FlagCount + 1
            LCount = FlagCount + 101
            MkDir folderpath & FCount & "_" & LCount
        Else                                          '=======================else if there isnt one, it will use the first file name to create the folder
            FCount = IntCount + 1
            LCount = IntCount + 100
            MkDir folderpath & FCount & "_" & LCount
        End If


        '====MOVE 100 FILES TO FOLDER====


        For Each objFile In objFSO.GetFolder(path)
            If FlagCount <> "" Then                   '====================if theres a flag count it will move the files starting after the flag count + 101
                objFile.CopyFile folderpath & FCount & "_" & LCount
                IntCount = FlagCount + 1
                If IntCount = FlagCount + 100 Then Exit For
            Else                                      '======================================else it will just move the first 100 files
                objFile.CopyFile folderpath & FCount & "_" & LCount
                IntCount = IntCount + 1
                If IntCount = IntCount + 100 Then Exit For
            End If
        Next

    End If

Else
    '===Do Nothing===
End If

End Sub

'=====Display Folders In Listbox=====
    '====Display Folder Items In Book====


'Call the function
DisplayFoldersInListBox folderpath & FCount & "_" & LCount, Me.Listbox1

Sub Button_Click()

    For Each File in Folderpath & FCount & "_" & LCount & "\" & Listbox.value
        '[INSERT BIG BOOK CODE]

    Next

End Sub

Private Sub DisplayFoldersInListBox(ByVal strRootFolder As String, ByRef lbxDisplay As MSForms.ListBox)

    Dim fso As Object
    Dim fsoRoot As Object
    Dim fsoFolder As Object

    'Make sure that root folder contains trailing backslash
    If Right$(strRootFolder, 1) <> "\" Then strRootFolder = strRootFolder & "\"

    'Get reference to the FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")

    'Get the root folder
    Set fsoRoot = fso.GetFolder(strRootFolder)

    'Clear the listbox
    lbxDisplay.Clear

    'Populate the listbox with subfolders of Root
    For Each fsoFolder In fsoRoot.SubFolders
        lbxDisplay.AddItem fsoFolder.Name
    Next fsoFolder

    'Clean up
    Set fsoRoot = Nothing
    Set fso = Nothing

End Sub

此链接：Copy only the first file of a folder VBA 似乎是文件处理的答案，但我不完全确定如何将它添加到我的脚本中。谁能帮帮我？

Answer 1

回到基础：

CopyXNumberOfFiles:Sub

Sub CopyXNumberOfFiles(SourceFolder As String, TargetFolder As String, Optional MaxNumFiles As Long = 100)
    Dim fso As Object, objFile As Object
    Dim count As Long
    Dim Path As String
    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not Right(SourceFolder, 1) = "\" Then SourceFolder = SourceFolder & "\"
    If Not Right(TargetFolder, 1) = "\" Then TargetFolder = TargetFolder & "\"

    For Each objFile In fso.GetFolder(SourceFolder).Files
        If objFile.Path Like "*.xls?" Then
            Path = TargetFolder & objFile.Name
            If Len(Dir(Path)) = 0 Then
                FileCopy objFile.Path, Path
                count = count + 1
                If count >= MaxNumFiles Then Exit For
            End If
        End If
    Next

End Sub

用法

 CopyXNumberOfFiles "C:\","C:\Data"

附录

此函数将复制文件并返回新文件路径的数组。

Function getCopyXNumberOfFiles(SourceFolder As String, TargetFolder As String, Optional MaxNumFiles As Long = 100) As String()
    Dim fso As Object, objFile As Object
    Dim count As Long, n As Long
    Dim Path As String
    Dim data() As String, results() As String
    ReDim data(1 To 2, 1 To MaxNumFiles)
    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not Right(SourceFolder, 1) = "\" Then SourceFolder = SourceFolder & "\"
    If Not Right(TargetFolder, 1) = "\" Then TargetFolder = TargetFolder & "\"

    For Each objFile In fso.GetFolder(SourceFolder).Files
        If objFile.Path Like "*.xls?" Then
            Path = TargetFolder & objFile.Name
            If Len(Dir(Path)) = 0 Then
                FileCopy objFile.Path, Path
                count = count + 1
                data(1, count) = objFile.Path
                data(2, count) = Path
                If count >= MaxNumFiles Then Exit For
            End If
        End If
    Next
    ReDim Preserve results(1 To count, 1 To 2)
    For n = 1 To count
        results(n, 1) = data(1, n)
        results(n, 2) = data(2, n)
    Next
    getCopyXNumberOfFiles = results
End Function

用法

第 1 列有原始路径，第 2 列有新路径。

Dim Files() as String, firstFilePath as String, lastFilePath as String

Files = getCopyXNumberOfFiles("C:\", "C:\New Folder\", 100)

原始路径

firstFilePath  = Files(1, 1)
lastFilePath  = Files(Ubound(Files), 1)

新路径

firstFilePath  = Files(1, 2)
lastFilePath  = Files(Ubound(Files), 2)