Question

感谢您提供的任何帮助。我已经设法使用宏来搜索文件夹和子文件夹并将它们超链接，并在列A中显示文件夹1，列在B列文件夹中的文件。

大约有200个文件夹和1600个文件。无论如何，我希望能够放置一个按钮并将宏附加到该按钮，该按钮将只允许从该按钮位置复制文件夹和文件名。

我在考虑将该按钮直接放在D列中的文件夹名称对面的D列中。

Answer 1

代码执行类似于您想要的内容。它以递归方式（参见TraversePath子程序）查找其中的所有路径和文件，并以与您在问题中发布的图像相同的方式将它们打印到“Sheet1”：文件夹名称写入“A”列（如一个超链接），该文件夹中的文件被写出到'B'列（再次作为超链接），一个按钮被放在'C'列。

使用要在“Sheet1”中打印出所有子文件夹和文件的根目录或顶级目录修改“CreateDirSheet”。 'TraversePath'的'1'参数是从'Sheet'开始打印文件夹/文件的行＃。

TraversePath子例程放置按钮并标识按下按钮时处理的宏处理程序。将两个参数传递给该例程：工作表的名称（在本例中为'Sheet1'）和在“A”列中给出文件夹的行号。

当按下按钮时，处理程序会提示用户输入目标路径，然后将列表'B'中的列表向下移动，将源文件夹中的所有文件（在“A”列中）复制到用户提供的目标文件夹中

这可能不完全是你所追求的，但应该是获得你想要的功能的良好起点。

Option Explicit

' Button event handler
Sub CopyDirBtn(shtName As String, rs As String)
  Dim sht As Worksheet
  Set sht = Worksheets(shtName)

  ' Get the destination path (where to copy files) from user
  Dim dpath As String, spath As String
  Dim fdialog As FileDialog
  Set fdialog = Application.FileDialog(msoFileDialogFolderPicker)
  With fdialog
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = Application.DefaultFilePath
    If .Show <> 0 Then
      dpath = .SelectedItems(1)
    Else
      Exit Sub
    End If
  End With

  ' Copy all files
  Dim r As Integer: r = CInt(rs)
  With sht
    spath = .Cells(r, "A")
    r = r + 1
    Do While .Cells(r, "B") <> ""
      FileCopy spath & .Cells(r, "B"), dpath & "\" & .Cells(r, "B")
      r = r + 1
    Loop
  End With
End Sub


' Populate sheet with folder/link links and buttons
Sub TraversePath(path As String, r As Integer)
  Dim currentPath As String, directory As Variant
  Dim dirCollection As Collection
  Set dirCollection = New Collection

  currentPath = Dir(path, vbDirectory)

  Dim sht As Worksheet
  Set sht = Worksheets("Sheet1")
  With sht
    'Add directory and hyperlink to sheet
    .Hyperlinks.Add Anchor:=.Cells(r, "A"), _
      Address:=path, _
      TextToDisplay:=path

    ' Add copy button
    Dim copyBtn As Button
    Set copyBtn = .Buttons.Add(Cells(r, "C").Left, _
                               Cells(r, "C").Top, 100#, 14#)
    With copyBtn
     .Caption = "Copy Files"
     .Name = "copyBtn_" & r
     .Locked = False
     .OnAction = "'CopyDirBtn """ & sht.Name & """, """ & r & """'"
    End With

    ' Add files and hyperlinks to sheet
    r = r + 1
    Do Until currentPath = vbNullString
      If Left(currentPath, 1) <> "." And _
         (GetAttr(path & currentPath) And vbDirectory) = vbDirectory Then
        dirCollection.Add currentPath
      Else
        If currentPath <> "." And currentPath <> ".." Then
          .Hyperlinks.Add Anchor:=.Cells(r, "B"), _
           Address:=path, _
           TextToDisplay:=currentPath
          r = r + 1
        End If
      End If
      currentPath = Dir()
    Loop
  End With

  'process remaining directories
  For Each directory In dirCollection
    TraversePath path & directory & "\", r
  Next directory
End Sub


' This is the main macro that populates the sheet
' Modify first parameter so it's your root folder path
Sub CreateDirSheet()
  TraversePath "D:\tmp\", 1
End Sub

复制行直到单元格不为空

1 个答案: