U盘能遍历子目录,手机盘符不能遍历子目录。

ning84 · 发表于 2024-5-24 09:42

本帖最后由 ning84 于 2024-5-24 20:08 编辑

在U盘运行xls正常。

H:\a
H:\a\1
            H:\a\1\0106RBM005300110.jpg
            H:\a\1\0107RBM001600110.jpg
            H:\a\1\0107RBM003200110.jpg
            H:\a\1\0107RBM005400110.jpg
            H:\a\1\0209YYH000100200.jpg
H:\a\1\1 - 副本 (4)
            H:\a\1\1 - 副本 (4)\0107RBM001600110.jpg
            H:\a\1\1 - 副本 (4)\0107RBM003200110.jpg
            H:\a\1\1 - 副本 (4)\0107RBM005400110.jpg

thisworkbook.path
结果，找不到子目录。

C:\Users\Administrator\AppData\Local\Microsoft\Windows\INetCache\IE\P6AH99C0

ning84 · 发表于 2024-5-24 20:05

在U盘运行正常。就是U盘稍微移动，会有麻烦。

Public Dict As Dictionary, Dict1 As Dictionary
Sub Test()
Set Dict = New Dictionary
Set Dict1 = New Dictionary
Dim Rng As Range, R1 As Range, R2 As Range
Set Rng = Selection
Dim Sht As Worksheet
Set Sht = Rng.Parent
Sht.Cells.Clear
Dim Fso As FileSystemObject
Set Fso = New FileSystemObject
Dim oFolder As Folder, oFile As File
Set oFolder = Fso.GetFolder(ThisWorkbook.Path)
TraverseSubFolders oFolder
Set R1 = Sht.Cells(3, 1).Resize(Dict.Count, 1)
R1.Resize(Dict.Count, 1) = Application.WorksheetFunction.Transpose(Dict.Keys)
R1(, 2).Resize(Dict.Count, 1) = Application.WorksheetFunction.Transpose(Dict.Items)
Set R2 = Sht.Cells(23, 1).Resize(Dict1.Count, 1)
R2.Resize(Dict1.Count, 1) = Application.WorksheetFunction.Transpose(Dict1.Keys)
R2(, 2).Resize(Dict1.Count, 1) = Application.WorksheetFunction.Transpose(Dict1.Items)
Debug.Print R1.Address, R2.Address
For ii = 1 To R1.Count
RepeatRng R1(ii, 1), R2
Next ii
End Sub
Sub TraverseSubFolders(oFolder As Folder)
Dim SubFolder As Folder
For Each SubFolder In oFolder.SubFolders
Debug.Print SubFolder.Path
TraverseFolderFile SubFolder
TraverseSubFolders SubFolder
Next SubFolder
End Sub
Function TraverseFolderFile(oFolder As Folder)
Dim oFile As File
For Each oFile In oFolder.Files
Debug.Print , oFile.Path
Dict(oFile.Name) = oFile.Path
Dict1(oFile.Path) = oFile.Name
Next oFile
End Function
Function RepeatRng(R1 As Range, R2 As Range)
Dim oDict As Dictionary
Set oDict = New Dictionary
For ii = 1 To R2.Rows.Count
Debug.Print R1(, 1), R2(ii, 2), R1(, 2), R2(ii, 1)
If R1(, 1) = R2(ii, 2) And R1(, 2) <> R2(ii, 1) Then
oDict(R2(ii, 1).Address) = ""
End If
Next ii
Debug.Print oDict.Count
If oDict.Count > 0 Then
R1(, 3) = oDict.Count
For jj = 0 To oDict.Count - 1
Debug.Print oDict.Keys(jj)
R1(, 4 + jj) = "=" & oDict.Keys(jj)
Next jj
End If
End Function

复制代码

		自动登录	找回密码
密码			免费注册