|
|
楼主 |
发表于 2019-6-15 10:06
|
显示全部楼层
参考你的第一段代码后已经百度了下，自行修改完成了，谢谢- Sub 重命名()
- Dim MyName$
- Dim varFileList As Variant
- MsgBox "选择要重命名文件所在的文件夹,点击确定！"
- With Application.FileDialog(msoFileDialogFolderPicker)
- .AllowMultiSelect = False
- .Show
- If .SelectedItems.Count = 0 Then Exit Sub '未选择文件夹
- renamepath = .SelectedItems(1)
- If Right(renamepath, 1) <> "" Then
- renamepath = renamepath + ""
- End If
- End With
- '获取文件夹中的所有文件列表
- varFileList = fcnGetFileList(renamepath)
- If Not IsArray(varFileList) Then
- MsgBox "未找到文件，请重新点击！", vbInformation
- Exit Sub
- End If
- MyName = Dir(renamepath & "*.xls")
- For l = 0 To UBound(varFileList)
- Dim fs
- Set fs = CreateObject("Scripting.FileSystemObject")
- With Workbooks.Open(renamepath & MyName)
- .Sheets(1).Select
- CC = Application.CountA(ActiveSheet.Range("C:C")) - 1
- .Close True
- End With
- oName = renamepath & CStr(varFileList(l))
- nName = Left(MyName, Len(MyName) - 4) & "-" & CC & ".xls"
- Name oName As nName
- MyName = Dir
- Next l
- Application.ScreenUpdating = True
- MsgBox "全部重命名成功！", vbInformation
- End Sub
- Private Function fcnGetFileList(ByVal strPath As String, Optional strFilter As String) As Variant
- ' 将文件列表放到数组
- Dim f As String
- Dim i As Integer
- Dim FileList() As String
- If strFilter = "" Then strFilter = "*.*"
- Select Case Right(strPath, 1)
- Case "", "/"
- strPath = Left(strPath, Len(strPath) - 1)
- End Select
- ReDim Preserve FileList(0)
- f = Dir(strPath & "" & strFilter)
- Do While Len(f) > 0
- ReDim Preserve FileList(i) As String
- FileList(i) = f
- i = i + 1
- f = Dir()
- Loop
- If FileList(0) <> Empty Then
- fcnGetFileList = FileList
- Else
- fcnGetFileList = False
- End If
- End Function
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2019-6-12 08:41
