ICode9
精准搜索请尝试： 精确搜索
首页
编程语言>
数据库
系统相关
互联网
其他分享
Python
Java
JavaScript
android
PHP
首页 > 其他分享> 文章详细

Excel  VBA批量修改文件名

2021-04-30 22:31:17  阅读：777  来源： 互联网

标签：count VBA End Sub 文件名 Excel myfile file qh


一、设计思路

1.选择要修改文件的文件夹；

2.获取文件夹内所有文件；

3.在Excel里面将文件改后名写好；

4.更改文件名；

5.清空数据；

 二、代码实现

1.可视化选择文件夹代码

With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = -1 Then
        qh_select_path = .SelectedItems(1)
        qh_path_oo = .SelectedItems(1)
    End If
End With

2.获取文件夹内所有文件列表函数

Function qh_get_all_file_fun(Optional qh_mypath0)    '获取文件夹内所有文件列表   作者：阙辉   20210429
Dim qh_myfso As Object
Dim qh_mypath
Dim qh_myfile
Dim qh_FolderName
Dim qh_myfile_count As Long
Dim qh_myfile_array
Dim qh_i As Long

On Error Resume Next

qh_mypath = qh_mypath0      '路径 阙

'路径为空则取文件同一文件夹 阙
If qh_mypath = "" Then
    qh_mypath = ThisWorkbook.Path '& "\" & qh_FolderName
Else
    qh_mypath = qh_mypath
End If

'实例化对象 阙
Set qh_myfso = CreateObject("Scripting.FileSystemObject")
'获取文件  阙
Set qh_myfile = qh_myfso.GetFolder(qh_mypath).Files
'获取文件数量
qh_myfile_count = qh_myfso.GetFolder(qh_mypath).Files.Count

'重定义数组 阙
ReDim qh_myfile_array(1 To qh_myfile_count)
'将文件名存储数组  阙
qh_i = 1
For Each qh_sh In qh_myfile
    qh_myfile_array(qh_i) = qh_sh.Name
    qh_i = qh_i + 1
'    MsgBox qh_myfso.GetExtensionName(qh_mypath & "\" & qh_sh.Name)   获取文件拓展名
Next

qh_get_all_file_fun = Array(qh_myfile_array, qh_myfile_count)
'输出数组：0 文件列表，1文件数量

End Function

3.获取文件列表主程序代码

Sub qh_get_all_file_sub(quehui)
If quehui <> "QH" Then
    Exit Sub
End If

On Error Resume Next
Dim qh_xu
Dim qh_file_count As Long
'aa = Application.GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText, MultiSelect)
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = -1 Then
        qh_select_path = .SelectedItems(1)
        qh_path_oo = .SelectedItems(1)
    End If
End With

qh_file_array = qh_get_all_file_fun(qh_select_path)
qh_file_count = qh_file_array(1)
qh_file_array0 = qh_file_array(0)
qh_file_count_00 = qh_file_count

ReDim qh_xu(1 To qh_file_count)

For qh_i = 1 To qh_file_count
    qh_xu(qh_i) = qh_i
Next

With Sheets(1)
    .Range("A5").Resize(qh_file_count) = Application.Transpose(qh_xu)
    .Range("B5").Resize(qh_file_count) = Application.Transpose(qh_file_array0)
End With

End Sub

4.修改文件名主程序代码

Sub qh_update_file_name(quehui)
If quehui <> "QH" Then
    Exit Sub
End If

If qh_path_oo = "" Or qh_file_count_00 = "" Then
    MsgBox "请重新运行'获取文件'，QH!"
    Exit Sub
End If

qh_count = qh_file_count_00 + 5 - 1

'实例化对象 阙
Set qh_myfso = CreateObject("Scripting.FileSystemObject")

With Sheets("QH_文件修改")
For qh_i = 5 To qh_count
    qh_old_name = qh_path_oo & "\" & .Cells(qh_i, 2)
    qh_HouZhuiMing = qh_myfso.GetExtensionName(qh_old_name)
    qh_new_name0 = .Cells(qh_i, 3)
    qh_new_name = qh_path_oo & "\" & qh_new_name0 & "." & qh_HouZhuiMing
    On Error Resume Next
'    On Error GoTo QH_ERROR1
    
    '如果改名称为空则不执行修改  日志报修改失败
    If qh_new_name0 <> "" Then
        Name qh_old_name As qh_new_name
        qh_KongBai = False
    Else
        '空白 qh_KongBai则为真
        qh_KongBai = True
    End If
    If qh_myfso.FileExists(qh_new_name) Then
        .Cells(qh_i, 4) = "修改成功,QH！"
        .Cells(qh_i, 5) = .Cells(qh_i, 3) & "." & qh_HouZhuiMing
    ElseIf qh_KongBai Then
        .Cells(qh_i, 4) = "改文件名（新）不能为空,QH！"
        .Cells(qh_i, 5) = ""
    Else
        .Cells(qh_i, 4) = "修改失败,QH！"
        .Cells(qh_i, 5) = ""
    End If
Next
'Exit Sub
'QH_ERROR1:
'
'Resume Next
End With
End Sub

5.清空数据调用程序代码

Sub qh_clear_data(quehui)
If quehui <> "QH" Then
    Exit Sub
End If
With Sheets("QH_文件修改")
    .Range("A5:E100000").ClearContents
End With
End Sub

6.完整代码

Public qh_path_oo   '定义公共变量
Public qh_file_count_00   '定义公共变量
Function qh_get_all_file_fun(Optional qh_mypath0)    '获取文件夹内所有文件列表   作者：阙辉   20210429
Dim qh_myfso As Object
Dim qh_mypath
Dim qh_myfile
Dim qh_FolderName
Dim qh_myfile_count As Long
Dim qh_myfile_array
Dim qh_i As Long

On Error Resume Next

qh_mypath = qh_mypath0      '路径 阙

'路径为空则取文件同一文件夹 阙
If qh_mypath = "" Then
    qh_mypath = ThisWorkbook.Path '& "\" & qh_FolderName
Else
    qh_mypath = qh_mypath
End If

'实例化对象 阙
Set qh_myfso = CreateObject("Scripting.FileSystemObject")
'获取文件  阙
Set qh_myfile = qh_myfso.GetFolder(qh_mypath).Files
'获取文件数量
qh_myfile_count = qh_myfso.GetFolder(qh_mypath).Files.Count

'重定义数组 阙
ReDim qh_myfile_array(1 To qh_myfile_count)
'将文件名存储数组  阙
qh_i = 1
For Each qh_sh In qh_myfile
    qh_myfile_array(qh_i) = qh_sh.Name
    qh_i = qh_i + 1
'    MsgBox qh_myfso.GetExtensionName(qh_mypath & "\" & qh_sh.Name)   获取文件拓展名
Next

qh_get_all_file_fun = Array(qh_myfile_array, qh_myfile_count)
'输出数组：0 文件列表，1文件数量

End Function
Sub qh_get_all_file_sub(quehui)
If quehui <> "QH" Then
    Exit Sub
End If

On Error Resume Next
Dim qh_xu
Dim qh_file_count As Long
'aa = Application.GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText, MultiSelect)
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = -1 Then
        qh_select_path = .SelectedItems(1)
        qh_path_oo = .SelectedItems(1)
    End If
End With

qh_file_array = qh_get_all_file_fun(qh_select_path)
qh_file_count = qh_file_array(1)
qh_file_array0 = qh_file_array(0)
qh_file_count_00 = qh_file_count

ReDim qh_xu(1 To qh_file_count)

For qh_i = 1 To qh_file_count
    qh_xu(qh_i) = qh_i
Next

With Sheets(1)
    .Range("A5").Resize(qh_file_count) = Application.Transpose(qh_xu)
    .Range("B5").Resize(qh_file_count) = Application.Transpose(qh_file_array0)
End With

End Sub
Sub qh_update_file_name(quehui)
If quehui <> "QH" Then
    Exit Sub
End If

If qh_path_oo = "" Or qh_file_count_00 = "" Then
    MsgBox "请重新运行'获取文件'，QH!"
    Exit Sub
End If

qh_count = qh_file_count_00 + 5 - 1

'实例化对象 阙
Set qh_myfso = CreateObject("Scripting.FileSystemObject")

With Sheets("QH_文件修改")
For qh_i = 5 To qh_count
    qh_old_name = qh_path_oo & "\" & .Cells(qh_i, 2)
    qh_HouZhuiMing = qh_myfso.GetExtensionName(qh_old_name)
    qh_new_name0 = .Cells(qh_i, 3)
    qh_new_name = qh_path_oo & "\" & qh_new_name0 & "." & qh_HouZhuiMing
    On Error Resume Next
'    On Error GoTo QH_ERROR1
    
    '如果改名称为空则不执行修改  日志报修改失败
    If qh_new_name0 <> "" Then
        Name qh_old_name As qh_new_name
        qh_KongBai = False
    Else
        '空白 qh_KongBai则为真
        qh_KongBai = True
    End If
    If qh_myfso.FileExists(qh_new_name) Then
        .Cells(qh_i, 4) = "修改成功,QH！"
        .Cells(qh_i, 5) = .Cells(qh_i, 3) & "." & qh_HouZhuiMing
    ElseIf qh_KongBai Then
        .Cells(qh_i, 4) = "改文件名（新）不能为空,QH！"
        .Cells(qh_i, 5) = ""
    Else
        .Cells(qh_i, 4) = "修改失败,QH！"
        .Cells(qh_i, 5) = ""
    End If
Next
'Exit Sub
'QH_ERROR1:
'
'Resume Next
End With
End Sub
Sub qh_clear_data(quehui)
If quehui <> "QH" Then
    Exit Sub
End If
With Sheets("QH_文件修改")
    .Range("A5:E100000").ClearContents
End With
End Sub

三、文件下载

 

标签：count,VBA,End,Sub,文件名,Excel,myfile,file,qh
来源： https://blog.csdn.net/qh0526wy/article/details/116309936

本站声明： 1. iCode9 技术分享网（下文简称本站）提供的所有内容，仅供技术学习、探讨和分享；
2. 关于本站的所有留言、评论、转载及引用，纯属内容发起人的个人观点，与本站观点和立场无关；
3. 关于本站的所有言论和文字，纯属内容发起人的个人观点，与本站观点和立场无关；
4. 本站文章均是网友提供，不完全保证技术分享内容的完整性、准确性、时效性、风险性和版权归属；如您发现该文章侵犯了您的权益，可联系我们第一时间进行删除；
5. 本站为非盈利性的个人网站，所有内容不会用来进行牟利，也不会利用任何形式的广告来间接获益，纯粹是为了广大技术爱好者提供技术内容和技术思想的分享性交流网站。

关于我们 | 联系我们 | 留言反馈

专注分享技术，共同学习，共同进步。侵权联系[81616952@qq.com]

Copyright (C)ICode9.com, All Rights Reserved.

ICode9版权所有