Question

我正在尝试编辑别人写的代码。一般来说，我没有做任何VBA和很少的编码。

原始代码是为5位数编写的，现在我们有6位数的文件。我试图复制代码，但最后将其更改为低于Next objFile上方当前代码的6位数字。这没效果。

这里的主要问题是我没有写原始代码，我不理解逻辑。我试过将所有的5改为6和99999改为999999.我尝试从Folder =“”复制，将它们更改为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条件下更改下限。像

If Test >= 10000 And Test <= 99999 Then

变为

If Test >= 100000 And Test <= 999999 Then

目前，当找到前五位数时，循环可能会退出。

用于包含较长文件名的代码，其中文件名为数字

2 个答案: