0

ハイパーリンク部分と作成したファイルリスト部分の両方で、マクロのセットアップとその動作がありますが、ファイルに見つからないように見えるファイルを取得しています

(例: Run Sheets\~$RUNSHEET - # 1-H.xlsx)

ファイルに直接移動し、フォルダー設定をオンにして非表示の結び目を表示すると、ファイルが存在せず、ファイルが作業されたときに残った一時ファイルのように見えます。

「~$」ファイルを除外するようにコードを変更できますか?

これが私のコードです。最初のコードはディレクトリリスターです:

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

2 つ目はハイパーリンカー コードです。

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

これらの追加の「~$」データをリストから削除する必要があります。一部のリストは数百のファイルになる可能性があるため、データの選択にはかなりの時間がかかります。

何か案は？

もう 1 つのヒントとして、すべてのデータに Excel ドキュメントが含まれているため、拡張子 .xlsx を削除することはできますか?

4

1 に答える 1