Код для включения более длинного имени файла, где имя файла является числом

Question

Я пытаюсь редактировать код, который кто-то написал. Я не сделал VBA и очень мало кодирования в целом.

Оригинальный код написан для пятизначного числа, и теперь у нас есть файлы, которые состоят из шести цифр. Я пытался скопировать код, но изменил его на 6 цифр ниже текущего кода выше Next objFile в конце. Это не сработало.

Основная проблема здесь в том, что я не написал оригинальный код и не понимаю логику. Я попытался просто изменить все 5 на 6 и 99999 на 999999. Я попытался скопировать из папки = "" вниз, изменив их на 6 цифр и вставив ниже Next objFile, Это тоже не сработало.

Sub CopyPics()

Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim varDirectory As Variant
Dim objSubFolder As Object

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(Application.ActiveWorkbook.Path)

Dim Dest As String
Dest = "R:\Field Assurance\FA PHOTOS AND INFORMATION\"

'Loop through each file in this folder
For Each objFile In objFolder.Files

    Folder = "" 'Empty old folder name
    MainFolder = "" 'Empty old folder name
    For i = 1 To Len(objFile.Name)
        Test = Mid(objFile.Name, i, 5)
        If Test >= 10000 And Test <= 99999 Then     'For files: Find any five numbers in a row and assume it to be the file number.
            Folder = "NC-" & Mid(objFile.Name, i, 5) 'If found, create new folder.
            i = Len(objFile.Name) 'In other words, take the first 5 numbers, then get out.
        End If
    Next

    For Each objSubFolder In objFolder.subfolders 'Find the main folder.
    If Right(Folder, 5) >= Mid(objSubFolder.Name, 4, 5) And Right(Folder, 5) <= Mid(objSubFolder.Name, 18, 5) Then 'If my file number is within the main folder bounds...
    MainFolder = objSubFolder.Name & "\" 'Use that folder.
    End If
    Next objSubFolder

    If Len(Folder) = 8 And Len(MainFolder) = 23 Then 'If real folders are identified...

    On Error Resume Next
    If Dir(Dest & MainFolder & Folder) = "" Then 'Check to see if the directory/folder does not exist...
        objFSO.CreateFolder (Dest & MainFolder & Folder) 'If not, make one.
    End If

    'Rename that file's directory to be the new one - aka cut and paste file into new folder.
    Name Application.ActiveWorkbook.Path & "\" & objFile.Name As Dest & MainFolder & Folder & "\" & objFile.Name

    End If

Next objFile

ActiveWorkbook.Close

End Sub

Answer 1

Это немного сложнее, чем ваш оригинальный код, но я думаю, что это более надежный...

Слегка проверено.

Option Explicit

Sub CopyPics()

    'use constants for fixed values
    Const DEST As String = "R:\Field Assurance\FA PHOTOS AND INFORMATION\"

    Dim objFSO As Object, srcFolder As Object, objFile As Object
    Dim objSubFolder As Object, destFolder As Object, fNum, folderName, picFolderName
    Dim FileWasMoved As Boolean, sMsg

    Set objFSO = CreateObject("Scripting.FileSystemObject")

    Set srcFolder = objFSO.GetFolder(Application.ActiveWorkbook.Path) 'ThisWorkbook.Path ?
    Set destFolder = objFSO.GetFolder(DEST) 'parent destination folder

    'Loop through each file in this folder
    For Each objFile In srcFolder.Files

        FileWasMoved = False 'reset "moved" flag

        fNum = ExtractNumber(objFile.Name) 'get the file number

        If Len(fNum) > 0 Then 'any number found?

            folderName = "NC-" & fNum

            For Each objSubFolder In destFolder.subfolders 'Find the subfolder.
                If IsTheCorrectFolder(objSubFolder.Name, fNum) Then

                    picFolderName = objSubFolder.Path & "\" & folderName
                    If Not objFSO.folderexists(picFolderName) Then
                        objFSO.CreateFolder picFolderName
                    End If
                    'move the file
                    Name objFile.Path As picFolderName & "\" & objFile.Name
                    FileWasMoved = True 'flag file as moved
                    Exit For
                End If
            Next objSubFolder
        End If 'filename contains a number

        'if file was not moved then add it to the list....
        If Not FileWasMoved Then sMsg = sMsg & vbLf & objFile.Name

    Next objFile

    'warn user if some files were not moved
    If Len(sMsg) > 0 Then
        MsgBox "Some files were not moved:" & vbLf & sMsg, vbExclamation
    End If


End Sub

'Return true/false depending on whether this is the correct
'  folder to hold the specified filenumber 
Function IsTheCorrectFolder(folderName, fileNumber) As Boolean
    Dim arr, num1, num2, rv As Boolean
    rv = False 'default return value
    arr = Split(folderName, "thru") 'split folder name on "thru"
    If UBound(arr) = 1 Then 'should have two parts
        'get the numbers from each part and compare against the file number
        num1 = ExtractNumber(arr(0))
        num2 = ExtractNumber(arr(1))
        If Len(num1) > 0 And Len(num2) > 0 Then
            fileNumber = CLng(fileNumber) 'convenrt to Long for comparison
            rv = (fileNumber >= CLng(num1) And fileNumber <= CLng(num2))
        End If
    End If
    IsTheCorrectFolder = rv
End Function

'Extract the first 5- or 6-digit number from a string
' Match is "greedy" so if there are six digits it will match 6 and
'   not just the first 5...
Function ExtractNumber(txt)
    Dim re As Object, allMatches, rv
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "(\d{5,6})"
    re.ignorecase = True
    re.Global = True
    Set allMatches = re.Execute(txt)
    If allMatches.Count > 0 Then rv = allMatches(0) 'if there's a match then return the first one
    ExtractNumber = rv
End Function

Answer 2

Вам также необходимо изменить нижний предел в условии ЕСЛИ. подобно

If Test >= 10000 And Test <= 99999 Then

становится

If Test >= 100000 And Test <= 999999 Then

В настоящее время цикл может завершаться, когда он находит первые пять цифр.