小白求助帮忙改个VBA自定义保存文件名

fj1204

小白求助，这个宏保存文件名能改成自定义吗，比如保存为    1审定表.xlsx   2审定表.xlsx    3审定表.xlsx   这样按序号以此类推

Sub 按订单拆分()

  Dim ar, Ran As Range, Dict As Object
  Dim p As String, strNo As String
  Dim i As Long, j As Long, k

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False

  p = ThisWorkbook.Path & "\4审计费明细表\"
  If Dir(p, vbDirectory) = "" Then MkDir p
'  p = p & "\"

  Set Dict = CreateObject("Scripting.Dictionary")
  ar = Range("C5", Range("C5").End(xlDown))
  For i = 1 To UBound(ar)
    strNo = Trim(ar(i, 1))
    If Len(strNo) Then If Not Dict.Exists(strNo) Then Dict.Add strNo, vbNullString
  Next

  For Each k In Dict.Keys
    Worksheets("审计费明细表").Copy
    With ActiveWorkbook
      With .Worksheets(1)
        .DrawingObjects.Delete
        Set Ran = Nothing
        ar = .Range("C1", .Range("C5").End(xlDown))
        For i = 5 To UBound(ar)
          If Trim(ar(i, 1)) <> k Then
            If Not Ran Is Nothing Then Set Ran = Union(Ran, .Rows(i)) Else Set Ran = .Rows(i)
          End If
        Next
        If Not Ran Is Nothing Then Ran.Delete
      End With
      .SaveAs p & k, 51
      .Close
    End With
  Next

  Set Dict = Nothing
  Set Ran = Nothing

  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Beep
End Sub

ssfx1982

Sub 按订单拆分()

  Dim ar, Ran As Range, Dict As Object
  Dim p As String, strNo As String, strText$
  Dim i As Long, j As Long, k

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  '请输入自定义名称，这里默认是"审定表" 如果是其他名字需手工另行输入
  strText = Trim(InputBox("请输入自定义后缀名" & Chr(10) & "e.g. 审定表、统计表 etc.", , "审定表"))
  p = ThisWorkbook.Path & "\4审计费明细表\"
  If Dir(p, vbDirectory) = "" Then MkDir p
'  p = p & "\"

  Set Dict = CreateObject("Scripting.Dictionary")
  ar = Range("C5", Range("C5").End(xlDown))
  For i = 1 To UBound(ar)
    strNo = Trim(ar(i, 1))
    If Len(strNo) Then If Not Dict.Exists(strNo) Then Dict.Add strNo, vbNullString
  Next

  For Each k In Dict.Keys
    Worksheets("审计费明细表").Copy
    With ActiveWorkbook
      With .Worksheets(1)
        .DrawingObjects.Delete
        Set Ran = Nothing
        ar = .Range("C1", .Range("C5").End(xlDown))
        For i = 5 To UBound(ar)
          If Trim(ar(i, 1)) <> k Then
            If Not Ran Is Nothing Then Set Ran = Union(Ran, .Rows(i)) Else Set Ran = .Rows(i)
          End If
        Next
        If Not Ran Is Nothing Then Ran.Delete
      End With
      .SaveAs p & k & strText, 51'原名称K加上自定义的后缀名
      .Close
    End With
  Next

  Set Dict = Nothing
  Set Ran = Nothing

  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Beep
End Sub