Question

所以我有我的宏设置及其工作，超链接部分和我已经制作的文件列表部分，但是他们正在拾取我似乎无法在我的文件中找到的文件

（即：Run Sheets \〜$ RUNSHEET - ＃1-H.xlsx）

当我直接转到文件并打开文件夹设置以查看隐藏和结果时，文件不存在，它们似乎也是我的文件工作时遗留的临时文件。

无论如何我可以更改我的代码以排除“〜$”文件吗？

这是我的代码，第一个是目录lister：

Sub ListFilesAndSubfolders()

  Dim FSO As Object
  Dim rsFSO As Object
  Dim baseFolder As Object
  Dim file As Object
  Dim folder As Object
  Dim row As Integer
  Dim name As String

  'Get the current folder
  Set FSO = CreateObject("scripting.filesystemobject")
  Set baseFolder = FSO.GetFolder(ThisWorkbook.Path)
  Set FSO = Nothing

  'Get the row at which to insert
  row = Range("A65536").End(xlUp).row + 1

  'Create the recordset for sorting
  Set rsFSO = CreateObject("ADODB.Recordset")
  With rsFSO.Fields
    .Append "Name", 200, 200
    .Append "Type", 200, 200
  End With
  rsFSO.Open

  ' Traverse the entire folder tree
  TraverseFolderTree baseFolder, baseFolder, rsFSO
  Set baseFolder = Nothing

  'Sort by type and name
  rsFSO.Sort = "Type ASC, Name ASC "
  rsFSO.MoveFirst

  'Populate the first column of the sheet
  While Not rsFSO.EOF
    name = rsFSO("Name").value
    If (name <> ThisWorkbook.name) Then
      Cells(row, 1).Formula = name
      row = row + 1
    End If
    rsFSO.MoveNext
  Wend

  'Close the recordset
  rsFSO.Close
  Set rsFSO = Nothing

End Sub

Private Sub TraverseFolderTree(ByVal parent As Object, ByVal node As Object, ByRef rs As Object)

  'List all files
  For Each file In node.Files

    Dim name As String
    name = Mid(file.Path, Len(parent.Path) + 2)

    rs.AddNew
    rs("Name") = name
    rs("Type") = "FILE"
    rs.Update
  Next

  'List all folders
  For Each folder In node.SubFolders
    TraverseFolderTree parent, folder, rs
  Next

End Sub

第二个是超链接代码：

Sub hyperlinker()

  Dim MOG As Object
  Dim rsMOG As Object
  Dim PrimeF As Object
  Dim Bit As Object
  Dim Foder As Object
  Dim Linger As Integer
  Dim Enigma As String
  Dim way As String


  'Get the current folder
  Set MOG = CreateObject("scripting.filesystemobject")
  Set PrimeF = MOG.GetFolder(ThisWorkbook.Path)
  Set MOG = Nothing

  'Get the row at which to insert
   Linger = Range("U65536").End(xlUp).row + 1

  'Create the recordset for sorting
  Set rsMOG = CreateObject("ADODB.Recordset")
  With rsMOG.Fields
    .Append "Way", 200, 200
    .Append "Enigma", 200, 200
    .Append "Bit", 200, 200
  End With
  rsMOG.Open

  ' Traverse the entire folder tree
  TraverseFolderTree PrimeF, PrimeF, rsMOG
  Set PrimeF = Nothing

  'Sort by type and name
  rsMOG.Sort = "Bit ASC, Enigma ASC "
  rsMOG.MoveFirst

  'Populate the first column of the sheet
   While Not rsMOG.EOF
    Enigma = rsMOG("Enigma").value
    way = rsMOG("Way").value
    If (Enigma <> ThisWorkbook.name) Then
      ActiveSheet.Hyperlinks.Add Anchor:=Cells(Linger, 21), Address:=way, TextToDisplay:=Enigma
      Linger = Linger + 1
    End If
    rsMOG.MoveNext
  Wend

  'Close the recordset
  rsMOG.Close
  Set rsMOG = Nothing

End Sub

Private Sub TraverseFolderTree(ByVal parent As Object, ByVal node As Object, ByRef rs As Object)

  'List all files
  For Each Bit In node.Files

    Dim Enigma As String
    Enigma = Mid(Bit.Path, Len(parent.Path) + 2)

    Dim way As String
    way = Mid(Bit.Path, Len(parent.Path) + 2)

    rs.AddNew
    rs("Way") = way
    rs("Enigma") = Enigma
    rs("Bit") = "Bit"
    rs.Update
  Next

  'List all folders
  For Each Foder In node.SubFolders
    TraverseFolderTree parent, Foder, rs
  Next

End Sub

我需要从我的列表中删除这些额外的“〜$”数据，有些列表可能是几百个文件，因此非常耗时。

任何想法？

另一个提示是，我可以删除.xlsx扩展名，因为我的所有数据都包含excel文档吗？

Answer 1

在lister目录中进行以下更改：

'List all files
  For Each file In node.Files
    if InStr(file.Path, "~$") > 0 then
      Dim name As String
      name = Mid(file.Path, Len(parent.Path) + 2)

      rs.AddNew
      rs("Name") = name
      rs("Type") = "FILE"
      rs.Update
    end if
  Next

在超链接代码中更改此：

  For Each Bit In node.Files
    if InStr(file.Path, "~$") > 0 then
      Dim Enigma As String
      Enigma = Mid(Bit.Path, Len(parent.Path) + 2)

      Dim way As String
      way = Mid(Bit.Path, Len(parent.Path) + 2)

      rs.AddNew
      rs("Way") = way
      rs("Enigma") = Enigma
      rs("Bit") = "Bit"
      rs.Update
    End If
  Next

我可以更改我的宏以排除文件中的特定文本吗？

1 个答案: