Как скопировать 100 файлов в папку на основе первого и последнего имени файла и отобразить в списке vba - PullRequest
Новая
       52

Как скопировать 100 файлов в папку на основе первого и последнего имени файла и отобразить в списке vba

0 голосов
/ 04 июля 2018

Я пытаюсь создать фрагмент сценария, который позволит мне скопировать 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

Эта ссылка: Копировать только первый файл из папки VBA Кажется, это ответ для копирования файлов, но я не совсем уверен, как добавить его в мой скрипт. Кто-нибудь может мне помочь?

1 Ответ

0 голосов
/ 04 июля 2018

Вернуться к основам:

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)
...