彰化一整天的論壇

 找回密碼
 立即註冊
查看: 133|回復: 15

rename_directory列出目錄有問題

[複製鏈接]
發表於 2021-4-1 13:14:03 | 顯示全部樓層 |閱讀模式
本帖最後由 yws0915 於 2021-4-1 13:44 編輯

老師做的改目錄VBA,我抄別人寫的東西把它新增兩個功能進去
自動建BAT檔(應該有人搞不定創新一個BAT檔)
列出底下所有目錄的功能
現在有個問題是列出目錄,按第二次它會列了兩筆,按第三次會列出三筆
請問是那一行造成的?


另外想請教一下,為什麼不用 name sourceFilename as descFilename,還要另外創建一個BAT?
  1. Private Sub cmdRename_Click()
  2.     Dim sourceFilename, descFilename
  3.     Dim i
  4.    
  5.     i = 2
  6.     sourceFilename = Cells(2, 1)
  7.     While Cells(i, 1) <> ""
  8.    
  9.         sourceFilename = Cells(i, 1)
  10.         descFilename = Excel.ActiveWorkbook.Path & "" & Cells(i, 2)
  11.         
  12.         Name sourceFilename As descFilename
  13.         
  14.         i = i + 1
  15.     Wend
  16.     MsgBox "處理完畢!!", vbOKOnly, "彰化一整天的blog(http://blog.bestdaylong.com)"

  17. End Sub
複製代碼


rename_directory.xlsm

27.9 KB, 下載次數: 2

回復

使用道具 舉報

 樓主| 發表於 2021-4-1 22:04:12 | 顯示全部樓層
  1. Sub LoopThroughFilePaths()

  2. Dim myArr
  3. Dim strPath As String
  4. Range("A:A").ClearContents
  5. Range("A1:B1") = Array("改名前目錄名", "改名後目錄名")

  6. strPath = ThisWorkbook.Path & ""
  7. myArr = GetSubFolders(strPath)
  8. [A1].Resize(UBound(myArr) + 1, 1).Offset(1) = Application.Transpose(myArr)

  9. Erase myArr
  10. Counter = 0
  11. End Sub
複製代碼
目前這樣就不會出現重複的,可是這不能在根目錄下執行
我在D:\下執行會出現權限不足,這該如何解決?
回復 支持 反對

使用道具 舉報

發表於 2021-4-2 09:34:34 | 顯示全部樓層
本帖最後由 imingho 於 2021-4-2 09:36 編輯

因為用內建的指令只要遇到UTF8的字元就會出錯,您可以用"堃"這個字去試看看。
回復 支持 反對

使用道具 舉報

發表於 2021-4-2 15:56:17 | 顯示全部樓層
您沒有將global變數counter清為0

  1. ' 資料來源https://blog.xuite.net/crdotlin/excel/9016095
  2. Public Arr() As String
  3. Public Counter As Long

  4. Sub LoopThroughFilePaths()
  5.     Dim myArr
  6.     Dim strPath As String
  7.     strPath = ThisWorkbook.Path & ""
  8.     myArr = GetSubFolders(strPath)
  9.     Counter = 0 '清除之前筆數
  10.    
  11.     [A1].Resize(UBound(myArr) + 1, 1).Offset(1) = Application.Transpose(myArr)
  12.     Erase myArr
  13. End Sub


  14. Function GetSubFolders(RootPath As String)
  15.     Dim fso As Object
  16.     Dim fld As Object
  17.     Dim sf As Object
  18.     Dim myArr
  19.    
  20.     Set fso = CreateObject("Scripting.FileSystemObject")
  21.     Set fld = fso.GetFolder(RootPath)
  22.     For Each sf In fld.SUBFOLDERS
  23.         ReDim Preserve Arr(Counter)
  24.         Arr(Counter) = sf.Path
  25.         Counter = Counter + 1
  26.         myArr = GetSubFolders(sf.Path)
  27.     Next
  28.     GetSubFolders = Arr
  29.     Set sf = Nothing
  30.     Set fld = Nothing
  31.     Set fso = Nothing
  32.    
  33.    

  34. End Function
複製代碼


rename_directory.xlsm

32.71 KB, 下載次數: 1

售價: 1 金錢  [記錄]

回復 支持 反對

使用道具 舉報

 樓主| 發表於 2021-4-2 19:10:45 | 顯示全部樓層
那不能在根目錄執行呢?
回復 支持 反對

使用道具 舉報

發表於 2021-4-2 21:06:52 | 顯示全部樓層
本帖最後由 imingho 於 2021-4-2 21:40 編輯
yws0915 發表於 2021-4-2 19:10
那不能在根目錄執行呢?

因為您是使用CreateObject("Scripting.FileSystemObject"),有些目錄會無法讀取例如: C:\Documents and Settings
您用偵錯看是那個目錄無辦法執行就把它用if判斷把它跳過。
回復 支持 反對

使用道具 舉報

 樓主| 發表於 2021-4-3 00:34:40 | 顯示全部樓層
https://blog.csdn.net/qq_24818403/article/details/103762490
剛試了一下這個,用選取的方式,可以讀到根目錄
C:\Documents and Settings這個也被讀到了
回復 支持 反對

使用道具 舉報

發表於 6 天前 | 顯示全部樓層
yws0915 發表於 2021-4-3 00:34
https://blog.csdn.net/qq_24818403/article/details/103762490
剛試了一下這個,用選取的方式,可以讀到根 ...

謝謝,我也學會另一種解法。
回復 支持 反對

使用道具 舉報

 樓主| 發表於 5 天前 | 顯示全部樓層
  1. Sub DirFolder()
  2.   Dim myDir
  3.   Range("A:B").ClearContents
  4.   Range("A1:B1") = Array("改名前目錄名", "改名後目錄名")
  5.   kk = 2
  6.   myDir = Dir(ThisWorkbook.Path & "\*", vbDirectory)
  7.   Do While myDir <> ""
  8.     If InStr(myDir, ".") = 0 Then
  9.       Cells(kk, 1) = myDir
  10.       kk = kk + 1
  11.     End If
  12.     myDir = Dir
  13.   Loop
  14.   '資料來源
  15.   'http://club.excelhome.net/thread-1026388-1-1.html
  16. End Sub
複製代碼
後來又找到這個更簡單好懂的
順便多加一個改完刪除BAT

rename_directory.xlsm

26.22 KB, 下載次數: 0

回復 支持 反對

使用道具 舉報

 樓主| 發表於 5 天前 | 顯示全部樓層
本帖最後由 yws0915 於 2021-4-6 13:33 編輯

我剛改了用選取的方式,可是路徑執行完它就沒東西了,所以把它寫到G1儲存格
有什麼方法可以把它記住不用G1輔助?

rename_directory(用選取的).xlsm

28.61 KB, 下載次數: 3

回復 支持 反對

使用道具 舉報

您需要登錄後才可以回帖 登錄 | 立即註冊

本版積分規則

Archiver|手機版|小黑屋|彰化一整天的論壇(Excel,Office)

GMT+8, 2021-4-11 02:15 , Processed in 0.115096 second(s), 20 queries .

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回復 返回頂部 返回列表