求助 excel 批量重命名

350977106

daxushen 发表于 2021-6-19 10:52
我那是Python写的，VBA目前不太熟悉，正在学习中。

那也谢谢啦！！！

legend01

谢谢分享。。。。。。。。。
认真阅读。

liulang0808

Sub 按钮1_Click()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myPath = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "\" Then myPath = myPath & "\"
    Set d = CreateObject("Scripting.dictionary")
    Set dnm = CreateObject("Scripting.dictionary")
    Set fso = CreateObject("Scripting.filesystemobject")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each f In fso.getfolder(myPath).Files
        With Workbooks.Open(f)
            nm = .Sheets(1).Name & .Sheets(1).[a4].Value
            dnm(nm) = dnm(nm) + 1
            d(f) = myPath & nm & "_" & dnm(nm) & "." & Split(f.Name, ".")(1)
            .Close False
        End With
    Next
    For Each k In d.keys
        Name k As d(k)
    Next k
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

liulang0808

附件内容供参考。。。。。。

350977106

谢谢老师的答案，看附件完美解决了我的问题。但在我的电脑上提示“没有与搜索匹配的项“。是什么原因？
win7,office2016

350977106

liulang0808 发表于 2021-6-21 12:17
附件内容供参考。。。。。。

谢谢老师，根据附件看，应该完美解决了我的问题。但在我的电脑上提示“没有与搜索条件匹配的项”，在网上看了一下，启动服务，索引等，没有效果。不知什么原因。

350977106

liulang0808 发表于 2021-6-21 12:17
附件内容供参考。。。。。。

谢谢老师的帮助，终于把代码弄明白了，老师对字典的应用太让人服气了！！！

350977106

Sub 工作簿批量重命名()
  On Error Resume Next '当程序出错时继续执行下一句
  Dim FileName, i As Integer '声明变量，由于GetOpenFilename的返回值是数组，变量只能用变体型
  Dim wb As Workbook
  Dim ShName As String
  '创建一个打开文件的对话框，允许多选，然后将返回值赋予变量fileToOpen
  FileName = Application.GetOpenFilename("EXCEL文件,*.xls;*.xlsx", , "请选择EXCEL文件", , True)
  If Err.Number > 0 Then Exit Sub '如果有错误，那么结束过程(单击了“取消”键时才会有错误)
  For i = 1 To UBound(FileName)   '遍历数组,Ubound函数用于计算数组中的数据个数
    'ThisWorkbook.Sheets(1).Cells(i, 1) = FileName(i) '将数组中的文件名称逐一入写入到单元格中
   Workbooks.Open (FileName(i))
   Set wb = ActiveWorkbook
   ' ThisWorkbook.Sheets(1).Cells(i, 2) = wb.Sheets(1).Name
   ' ThisWorkbook.Sheets(1).Cells(i, 3) = wb.Sheets(1).Cells(4, 1)
     ShName = wb.Sheets(1).Name & wb.Sheets(1).Cells(4, 1) & Timer
   'ThisWorkbook.Sheets(1).Cells(i, 4) = ShName
' wb.SaveAs "d:\ssx\excelnew\" & ShName & ".xls"  '另存到d:\ssx\excelnew\
' wb.SaveAs ShName & ".xls"   '另存到当前文件夹下
'  wb.SaveAs "C:\Users\Administrator\Desktop\ssx\excelnew\" & ShName & ".xls"

   wb.Close
  Name FileName(i) As ShName & ".xls"    '重命名
  Next i
End Sub

350977106

Sub test()
  On Error Resume Next '当程序出错时继续执行下一句
  Dim FileName, i As Integer '声明变量，由于GetOpenFilename的返回值是数组，变量只能用变体型
  Dim wb As Workbook
  Dim ShName As String
  FileName = Application.GetOpenFilename("EXCEL文件,*.xls;*.xlsx", , "请选择EXCEL文件", , True)
  If Err.Number > 0 Then Exit Sub '如果有错误，那么结束过程(单击了“取消”键时才会有错误)
  For i = 1 To UBound(FileName)   '遍历数组,Ubound函数用于计算数组中的数据个数
   Workbooks.Open (FileName(i))
   Set wb = ActiveWorkbook
     ShName = wb.Sheets(1).Name & wb.Sheets(1).Cells(4, 1) ' & Timer
   ThisWorkbook.Sheets(1).Cells(i, 1) = ShName
ThisWorkbook.Sheets(1).Cells(i, 2) = Application.WorksheetFunction.CountIf(ThisWorkbook.Sheets(1).Range("A1:A" & i), ThisWorkbook.Sheets(1).Range("A" & i))
  
  ShName = ShName & "-" & ThisWorkbook.Sheets(1).Cells(i, 2)
  'wb.SaveAs "C:\Users\Administrator\Desktop\ssx\excelnew\"  & ShName & "-"  & ".xls"

   wb.Close
   Name FileName(i) As ShName & ".xls"      '重命名
   
   Next i
  
Cells.Clear
  
End Sub

350977106

数组字典方法解决了，真高兴！！！
Sub test()
    Application.ScreenUpdating = False
    On Error Resume Next '当程序出错时继续执行下一句
    Dim FileName, i As Integer '声明变量，由于GetOpenFilename的返回值是数组，变量只能用变体型
    Dim wb As Workbook
    Dim ShName As String
    Dim dic As Object, brr(), Arr
    Set dic = CreateObject("scripting.dictionary")
    FileName = Application.GetOpenFilename("EXCEL文件,*.xls;*.xlsx", , "请选择EXCEL文件", , True)
    If Err.Number > 0 Then Exit Sub '如果有错误，那么结束过程(单击了“取消”键时才会有错误)
    For i = 1 To UBound(FileName)   '遍历数组,Ubound函数用于计算数组中的数据个数
        
        ReDim Arr(1 To UBound(FileName))
        ReDim brr(1 To UBound(FileName))
        
        Workbooks.Open (FileName(i))
        Set wb = ActiveWorkbook
        ShName = wb.Sheets(1).Name & wb.Sheets(1).Cells(4, 1) ' & Timer
        Arr(i) = ShName
        If dic.exists(Arr(i)) Then
            dic(Arr(i)) = dic(Arr(i)) + 1
            brr(i) = dic(Arr(i))
        Else
            dic.Add Arr(i), 0
            brr(i) = 0
        End If
        If brr(i) = 0 Then
            Arr(i) = Arr(i)
        Else
            Arr(i) = Arr(i) & "-" & brr(i)
        End If
        wb.SaveAs "C:\Users\Administrator\Desktop\test\excelnew\" & Arr(i) & ".xls"
        wb.Close
        Name FileName(i) As Arr(i) & ".xls"      '重命名
        Next i
        Application.ScreenUpdating = True
        End Sub