Question

我编写了下面的脚本，如果它不存在，则在给定位置创建一个文件夹，该文件夹以工作簿中的单元格命名。

Dim fso As Object

Dim fldrname As String
Dim fldrpath As String
Dim sFileType As String
Dim sSourcePath As String
Dim Destination As String

Set fso = CreateObject("scripting.filesystemobject")
sSourcePath = "\\INSURANCE\IT\FileData\Computers\DIPS\"

fldrname = Worksheets("Applications").Range("A2").Value
fldrpath = "\\INSURANCE\IT\FileData\Computers\DIPS\DIP Archive\" & fldrname
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
    End If
End If

我现在正在尝试将sSourcePath中的所有.xlsm文件复制到新创建的位置fldrpath＆amp; \ fldrname但所有尝试都失败了。我对VBA还是比较新的，所以任何帮助都会受到赞赏。我听说过.copyfile但是我不知道如何在这个例子中使用它。提前谢谢。

Answer 1

我没有filesystemobject这样做。

Sub copyfiles()
    Dim source_file As String, dest_file As String
    Dim source_path As String, dest_path As String
    Dim i As Long, file_array As Variant

    source_path = "\\INSURANCE\IT\FileData\Computers\DIPS"
    dest_path = "\\INSURANCE\IT\FileData\Computers\DIPS\DIP Archive"

    source_file = Dir(source_path & "\" & "*.xlsm")
    Do Until source_file = ""
        If Not IsArray(file_array) Then
            ReDim file_array(0) As Variant
        Else
            ReDim Preserve file_array(UBound(file_array) + 1) As Variant
        End If

        file_array(UBound(file_array)) = source_file
        source_file = Dir
    Loop

    'If new folder is not existed, create it.
    If Dir(dest_path, 16) = "" Then MkDir dest_path   '16=vbDirectory

    For i = LBound(file_array) To UBound(file_array)
        FileCopy source_path & "\" & file_array(i), dest_path & "\" & file_array(i)
    Next i
End Sub

Answer 2

我对此的看法

Sub copyFiles()

    Dim fldrname As String, fldrpath As String, sFileType As String
    Dim sSourcePath As String, Destination As String

    Dim fso As Object, fFolder As Object, fFile As Object

    Set fso = CreateObject("scripting.filesystemobject")
    sSourcePath = "\\SourcePath" '"\\INSURANCE\IT\FileData\Computers\DIPS\"

    fldrname = "data\" 'Worksheets("Applications").Range("A2").Value
    fldrpath = "\\SourcePath\Archive\" & fldrname '"\\INSURANCE\IT\FileData\Computers\DIPS\DIP Archive\" & fldrname

    If Not fso.folderexists(fldrpath) Then
        fso.createfolder (fldrpath)
    End If

    Set fFolder = fso.GetFolder(sSourcePath)

    For Each fFile In fFolder.Files

        'If Not (fso.FileExists(fldrpath & fFile.Name)) Then fFile.Copy fldrpath, Overwritefiles:=False
        fFile.Copy fldrpath, Overwritefiles:=True

    Next fFile

End Sub

将所有excel文件从一个位置复制到另一个位置

2 个答案: