求高手帮助，如何批量修改让每个文件和它所在的文件夹同名

lxl46

朱荣兴 发表于 2017-10-22 16:48
问题不简单，但是，楼主又连一个附件都懒得上传，就把本来可能解决的问题变得不可能解决了，哈哈

小弟第一次发帖，不懂规矩，附件已上传，见谅啊

lxl46

duquancai 发表于 2017-10-22 17:14
遍历文件夹及子文件夹，获取文件夹名 同时对该文件夹下的文件进行判读 如果只有一个文件 那么文件名就修改 ...

貌似好难……

duquancai

lxl46 发表于 2017-10-22 17:17
貌似好难……

难点有3
1.遍历文件夹及子文件夹及其下面的文件
2.判断文件是否存在，判断当前文件夹下面是否存在多个文件还是1个文件
3.按照需求修改文件名
综上所述：建议采用创建一个fso实例  用这个实例进行   遍历、判断、修改等操作！！！

chxw68

1. Sub test()
   
2.   Dim arr(), brr()
   
3.   Dim r%, i%
   
4.   Dim mypath$, myanme$
   
5.   mypath = ThisWorkbook.Path & ""
   
6.   myname = Dir(myapth & "*.*", vbDirectory)
   
7.   m = 0
   
8.   Do While myname <> ""
   
9.     If myname <> "." And myname <> ".." Then
   
10.       If GetAttr(mypath & myname) = vbDirectory Then
    
11.         m = m + 1
    
12.         ReDim Preserve arr(1 To m)
    
13.         arr(m) = myname
    
14.       End If
    
15.     End If
    
16.     myname = Dir()
    
17.   Loop
    
18.   For k = 1 To UBound(arr)
    
19.     mypath = ThisWorkbook.Path & "" & arr(k) & ""
    
20.     myname = Dir(mypath & "*.docx")
    
21.     m = 0
    
22.     Do While myname <> ""
    
23.       m = m + 1
    
24.       ReDim Preserve brr(1 To m)
    
25.       brr(m) = myname
    
26.       myname = Dir()
    
27.     Loop
    
28.     For i = 1 To UBound(brr)
    
29.       Name mypath & brr(i) As mypath & arr(k) & "-" & Format(i, "000") & "." & Split(brr(i), ".")(1)
    
30.     Next
    
31.   Next
    
32. End Sub
    
33. 
    

复制代码

chxw68

详见附件。

lxl46

chxw68 发表于 2017-10-23 12:11

非常感谢大侠的帮助，我现在还是新人，没有花花可以送，等到了初级我一定送。还有，可能是我电脑的问题，代码运行报错，我自己在努力努力吧。再次非常感谢您的帮助。

cqcbc

chxw68 发表于 2017-10-23 12:12
详见附件。

谢谢老师，但代码中有几个小问题，变量前后不一致。
Sub test()
  Dim arr(), brr()
  Dim r%, i%
  Dim mypath$, myname$
  mypath = ThisWorkbook.Path & "\"
  myname = Dir(mypath & "*.*", vbDirectory)
  m = 0
  Do While myname <> ""
    If myname <> "." And myname <> ".." Then
      If GetAttr(mypath & myname) = vbDirectory Then
        m = m + 1
        ReDim Preserve arr(1 To m)
        arr(m) = myname
      End If
    End If
    myname = Dir()
  Loop
  For k = 1 To UBound(arr)
    mypath = ThisWorkbook.Path & "\" & arr(k) & "\"
    myname = Dir(mypath & "*.docx")
    m = 0
    Do While myname <> ""
      m = m + 1
      ReDim Preserve brr(1 To m)
      brr(m) = myname
      myname = Dir()
    Loop
    For i = 1 To UBound(brr)
      Name mypath & brr(i) As mypath & arr(k) & "-" & Format(i, "000") & "." & Split(brr(i), ".")(1)
    Next
  Next
End Sub

chxw68

cqcbc 发表于 2017-10-23 14:47
谢谢老师，但代码中有几个小问题，变量前后不一致。
Sub test()
  Dim arr(), brr()

哪几个变量不一致？

坠网老朱

Sub 文件列表()
     Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker) '选取并指定文件夹路径
      .Show
       If .SelectedItems.Count = 0 Then Exit Sub
          folderpath = .SelectedItems(1) ' 提取文件夹路径
End With
     Getfd (folderpath & "\")
    Application.ScreenUpdating = True
End Sub
Sub Getfd(ByVal pth)
     Dim n As String
     Set fso = CreateObject("scripting.filesystemobject")
     Set ff = fso.getfolder(pth)
     For Each f In ff.Files         '具体提取哪类文件，还是需要根据文件扩展名进行处理
     ss = ff.Files.Count
     n = fso.getbasename(f)
     m = fso.getbasename(ff)
       If ss > 1 Then
         s = s + 1
         f.Name = m & "-" & n & "-0" & s
       Else
         f.Name = m & "-" & n
       End If
     Next f
     s = 0
     For Each fd In ff.subfolders
         Getfd (fd)
     Next fd
End Sub

cqcbc

chxw68 发表于 2017-10-23 14:48
哪几个变量不一致？

第4行mypath与第6行myapth，第4行myanme与第8行myname。