VBA将文件另存为

时间:2015-04-07 13:46:19

标签: excel-vba excel-2013 vba excel

我想知道是否有人可以帮助我。

我使用下面的代码动态创建给定文件夹中的文件列表。

在列E中,列表的每一行都有一个链接'点击此处打开'允许用户打开每个文件。

但我现在希望改变这一点,而不是打开文件,链接将打开“保存”字样。对话框允许用户将文件发送到用户选择的文件夹,我必须承认这个问题让我困惑了一个多星期了。

Public Sub ListFilesInFolder(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)

    Dim LastRow As Long

    On Error Resume Next
    For Each FileItem In SourceFolder.Files
        ' display file properties
        Cells(iRow, 3).Formula = iRow - 12
        Cells(iRow, 4).Formula = FileItem.Name
        Cells(iRow, 5).Select
        Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
        FileItem.Path, TextToDisplay:="Click Here to Open"
        iRow = iRow + 1 ' next row number

        With ActiveSheet
            LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
            LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        End With

        For Each Cell In Range("C13:E" & LastRow) ''change range accordingly
            If Cell.Row Mod 2 = 1 Then ''highlights row 2,4,6 etc|= 0 highlights 1,3,5
                Cell.Interior.Color = RGB(232, 232, 232) ''color to preference
            Else
                Cell.Interior.Color = RGB(141, 180, 226) 'color to preference or remove
            End If
        Next Cell
    Next FileItem

    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder, True
        Next SubFolder
    End If
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
End Sub

我尝试过使用命令' Application.Dialogs(xlDialogSaveAs)。显示'在代码的每一行中,我都无法使其工作,因为它只是要求用户在创建列表时保存文件。

我只是想知道是否有人可以看到这个,让我知道我哪里出错了。

非常感谢和亲切的问候

克里斯

1 个答案:

答案 0 :(得分:0)

以下是将文件从给定地点复制到用户选择的目标文件夹的相关代码。我将它包装在FollowHyperlink的工作表事件中,因为它听起来像是基于点击而执行此操作。

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)

    Dim FSO
    Dim sFile As String
    Dim sDFolder As String

    'path to file to copy, you will want to point this at a cell range
    'this assume a single cell is selected
    sFile = Target.Range.Value

    'destination folder
    Dim fldr As FileDialog
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)

    fldr.AllowMultiSelect = False
    fldr.Show

    'add the end slash for the copy operation
    sDFolder = fldr.SelectedItems(1) & "\"

    'FSO object to copy the file... True below overwrites if needed
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFile (sFile), sDFolder, True

End Sub