VBAで Excelファイルをリネームする、かつXLSXに保存し直す

 //Mid(BaseNames(i), 3, 2) に関してはいわゆるお手盛り式。

　配列として取得したファイル名を左から3文字目の2文字だけ切り取って保存

　というものです。

//ActiveWorkbook.Worksheets(1).Range("O24").Valueと、

　ActiveWorkbook.Close　に関してもかなりリスキーです。

　ここはWorkbooks（”ファイル名.xls”）と指定したほうが丁寧なのでしょうが

　便利なのでついActiveworkbookをつかってしまいます。

//wwwの彼方におられるVBA職人さん方々ご笑納ください。

//このコードだとファイル名前が重複すると躓きます。

　改めてコード考えてます。

//重複する心配がない時にはこれは使えるのですが、汎用性がないですね...考えます

Private Sub CommandButton5_Click()

Dim myPath, SerchFolder, SerchSubFolder As Variant

   myPath = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\") - 1) & "\"  '親パスのフルパス

''myPath = ThisWorkbook.Path & "\"　'自分自身のフルパス

'

SerchFolder = myPath & UserForm1.ComboBox9.Value & "-Excel" & "\"

SerchSubFolder = SerchFolder & UserForm1.ComboBox8.Value & "月" & "\"

    Dim FSO As Object, f As Variant, BaseNames(), ErrorFileName() As String, MyCnt, cnt As Long, i As Long

    Set FSO = CreateObject("Scripting.FileSystemObject")

    ReDim BaseNames(FSO.GetFolder(SerchSubFolder).Files.Count)

    For Each f In FSO.GetFolder(SerchSubFolder).Files

        If LCase(FSO.GetExtensionName(f.Name)) = "xls" Then

            cnt = cnt + 1

            BaseNames(cnt) = FSO.GetBaseName(f.Name)

'

        End If

       

   

 Next f

    If cnt = 0 Then

        Debug.Print "xlsファイルはありません", vbExclamation

        GoTo StepEnd

    Else

        For i = 1 To cnt

            UserForm1.ListBox5.AddItem BaseNames(i)

           Workbooks.Open (SerchSubFolder & BaseNames(i) & ".xls")

            

            ActiveWorkbook.SaveAs FileName:=SerchSubFolder & UserForm1.ComboBox9.Value & "年　" & UserForm1.ComboBox8.Value & "月　" & "　" & "？？書　" & Mid(BaseNames(i), 3, 2) & "　" & ActiveWorkbook.Worksheets(1).Range("O24").Value, FileFormat:=xlOpenXMLWorkbook

            ActiveWorkbook.Close

        Next i

    End If

   

   

StepEnd:

    Set FSO = Nothing

    Set myPath = Nothing

    Set SerchFolder = Nothing

    Set SerchSubFolder = Nothing

    MyCnt = ""

    

Unload Me

End Sub