文件传输

Question

Sub Copyfiles()

    ' Updateby Extendoffice

    Dim xRg As Range, xCell As Range
    Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
    Dim xSPathStr As Variant, xDPathStr As Variant
    Dim xVal As String
    Dim FSO As Object, folder1 As Object

    Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", ActiveWindow.RangeSelection.Address, , , , , 8)

    If xRg Is Nothing Then Exit Sub

    Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xSFileDlg.Title = " Please select the original folder:"
    If xSFileDlg.Show <> -1 Then Exit Sub
    xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"

    Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xDFileDlg.Title = " Please select the destination folder:"
    If xDFileDlg.Show <> -1 Then Exit Sub
    xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"

    Call sCopyFiles(xRg, xSPathStr, xDPathStr)

End Sub

Sub sCopyFiles(xRg As Range, xSPathStr As Variant, xDPathStr As Variant)
    Dim xCell As Range
    Dim xVal As String
    Dim xMainFolder As String
    Dim xSubFolder As String
    Dim FSO As Object
    Dim xI As Integer

    If Dir(xDPathStr, vbDirectory) = "" Then
        MkDir (xDPathStr)
    End If

    Set FSO = CreateObject("Scripting.FileSystemObject")

    For xI = 1 To xRg.Count
        Set xCell = xRg.Item(xI)
        xVal = xCell.Value
        xMainFolder = xCell.Offset(0, 1).Value ' Column B for main folder
        xSubFolder = xCell.Offset(0, 2).Value ' Column C for subfolder

        If xMainFolder <> "" Then
            xMainFolder = xDPathStr & xMainFolder & "\"
            If Dir(xMainFolder, vbDirectory) = "" Then
                MkDir (xMainFolder)
            End If

            If xSubFolder <> "" Then
                If TypeName(xVal) = "String" And Not (xVal = "") Then
                    On Error GoTo E1
                    If Dir(xSPathStr & xVal, 16) <> Empty Then
                        ' Delete any existing subfolder or file with the same name in the destination folder
                        If Dir(xDPathStr & xSubFolder, vbDirectory) <> "" Then
                            FSO.DeleteFolder xDPathStr & xSubFolder, True
                        ElseIf Dir(xDPathStr & xVal, vbNormal) <> "" Then
                            FSO.DeleteFile xDPathStr & xVal, True
                        End If
                        
                        ' Create the subfolder inside the main folder
                        If Dir(xMainFolder & xSubFolder, vbDirectory) = "" Then
                            MkDir (xMainFolder & xSubFolder)
                        End If
                        
                        ' Copy the file to the subfolder inside the main folder
                        FileCopy xSPathStr & xVal, xMainFolder & xSubFolder & "\" & xVal
                    End If
                End If
            Else
                If TypeName(xVal) = "String" And Not (xVal = "") Then
                    On Error GoTo E1
                    If Dir(xSPathStr & xVal, 16) <> Empty Then
                        ' Delete any existing file with the same name in the destination folder
                        If Dir(xDPathStr & xVal, vbNormal) <> "" Then
                            FSO.DeleteFile xDPathStr & xVal, True
                        End If
                        
                        ' Copy the file to the main folder
                        FileCopy xSPathStr & xVal, xMainFolder & xVal
                    End If
                End If
            End If
        Else
            ' If there is no main folder, place the file directly in the destination folder
            If TypeName(xVal) = "String" And Not (xVal = "") Then
                On Error GoTo E1
                If Dir(xSPathStr & xVal, 16) <> Empty Then
                    ' Delete any existing file with the same name in the destination folder
                    If Dir(xDPathStr & xVal, vbNormal) <> "" Then
                        FSO.DeleteFile xDPathStr & xVal, True
                    End If
                    
                    ' Copy the file to the destination folder
                    FileCopy xSPathStr & xVal, xDPathStr & xVal
                End If
            End If
        End If

E1:
    Next xI
End Sub

代码基本上应该从源文件夹中获取文件并将其放入文件夹或子文件夹中。例如，当您看到图像 27256l 时，应将其放入名为“女人”的主文件夹中名为“女人裤子”的子文件夹中，而另一张图片应位于主文件夹中。它正确地进行了选择和拾取，但是它在主文件夹位置之外创建了一个名为“女人裤子”的额外子文件夹，我无法解决该问题。

Answer 1

        If xMainFolder <> "" Then
            Dim aDir : aDir = Split(xMainFolder)
            If StrComp(aDir(Ubound(aDir)-1), xMainFolder, vbTextCompare) <> 0 Then
                xMainFolder = xDPathStr & xMainFolder & "\"
                If Dir(xMainFolder, vbDirectory) = "" Then
                    MkDir (xMainFolder)
                End If
            End If

            If xSubFolder <> "" Then