VBAで ユーザーフォームのコンボボックスで選んだファイルを開き（ひな形） これをコピーして新しいファイルを作り コンボボックスの値と名簿.csvから検索した氏名などで名前を付けて保存し 名前がかぶったら（ｎ）として保存

//失敗も勉強のうち　ということで「失敗を消去せずに」置いておきます

//「ここでこういうことをすると失敗するんですね」 をご堪能いただきたく。

//　行頭の　’　がコメントアウトなので、ここにコードが続けばそこが失敗です

Private Sub CommandButton2_Click()

'？？書の作成

Dim myPath, mySubPath, YearFolder As String

Dim FileName, ListBox1 As String

Dim bk As Workbook

Dim myDay As String

Dim wbNew As String

 

'On Error Resume Next

 '自身以外のworkbooksを閉じる

  For Each bk In Workbooks

    If Not (bk Is ThisWorkbook) Then

      bk.Close savechanges:=False

    End If

  Next

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

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

mySubPath = myPath & "？？書-ひな形" & "\"

FileName = UserForm1.ComboBox3 & ".xls"

If UserForm1.ComboBox3 = "" Then

 MsgBox "様式を選択してください"

 Exit Sub

Else

Workbooks.Open mySubPath & FileName

ActiveWindow.SelectedSheets.Copy

wbNew = ActiveWorkbook.Name

End If

Dim flag As Boolean

 flag = False

Dim trgtFileName As String

trgtFileName = myPath & "\" & "名簿.csv"

' ワークブックオブジェクトを定義する

Dim wb As Workbook

'開いている全ブックにループ処理を実行する

For Each wb In Workbooks

'    ブックの名前が目的のブック名と一致した場合､処理を実行

    If wb.Name = trgtFileName Then

'        フラグをTrueにしてループを抜ける

        flg = True

        Exit For

    End If

Next

'フラグがFalseだった場合､ブックを開く

If flg = False Then

    Workbooks.Open trgtFileName

End If

Set wb = Nothing

''invoiceday----

Dim myDayStr, ggg, e, mm, dd As String

Dim myDayLng As Long

myDay = Format(Date, "gggemmdd")

myDayStr = CStr(myDay)

ggg = StrConv(Left(myDay, 2), vbWide)

e = StrConv(Mid(myDay, 3, 1), vbWide)

mm = StrConv(UserForm1.ComboBox2.Value, vbWide)

dd = StrConv(UserForm1.ComboBox4.Value, vbWide)

invoiceday = ggg & "　　　　　　" & e & "年" & "　　　　　　" & mm & "月" & "　　　　　　　" & dd & "日"

'Debug.Print invoiceday

''--------------

Dim LastRow As Integer

Dim MyRange As Range

Dim FirstCell As Range

Dim Str As String

Dim myFind, SavePath, SaveName As String

LastRow = ActiveWorkbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row

SavePath = myPath & "2024-Excel" & "\" & UserForm1.ComboBox2.Value & "月"

SaveName = Format(Date, "yyyy") & "年　" & UserForm1.ComboBox2.Value & "月　" & "？？書　"

'Debug.Print SaveName

myFind = UserForm1.ComboBox3.Value

Set MyRange = ActiveWorkbook.Worksheets(1).Range(Cells(1, 5), Cells(LastRow, 8)).Find(what:=myFind, LookAt:=xlPart)

If MyRange Is Nothing Then

Debug.Print "みつかりません"

Exit Sub

 Else

        Set FirstCell = MyRange

    End If

   

  ''--'For NameTrap

'

''  Dim i As Integer

'  Dim FSO, Temp As Object

  Dim TargetFiles As Files

'  Dim SaveNameP As String

 

  

    SaveNameP = myPath & Format(Date, "yyyy") & "-Excel" & "\" & UserForm1.ComboBox2.Value & "月"

    Set FSO = New FileSystemObject

    Set TargetFiles = FSO.GetFolder(SaveNameP).Files

'    Debug.Print TargetFiles.Count

'

'    For Each Temp In TargetFiles

'        Debug.Print Temp.Name '表示されたら名前の重複あり

'

'    Next

'

'

'' ---   Debug.Print "ここです"

   

   

    Dim fileSaveName As Variant

    Dim fileSaveName_name As String

    Dim fileSaveName_path As String

    Dim k As Integer

   

'''----Do--名前重複なし--

 

    Do

    

    

    

Peopele = Workbooks("名簿.csv").Worksheets(1).Cells(MyRange.Row, 1).Value

    '''保存ダイアログを開く

    fileSaveName = (SaveNameP & "\" & SaveName & Left(Peopele, 2) & ".xlsx")

   

'    Debug.Print fileSaveName

'    Application.GetSaveAsFilename( _

'                    InitialFileName:=dtDate & ".csv", _

'                    FileFilter:="CSVファイル(*.csv),*.csv", _

'                    FilterIndex:=1, _

'                    Title:="保存ファイルの指定")

'    If fileSaveName = False Then Exit Sub

    '''保存しようとしたファイル名と既に同じファイル名が存在するならば、

    '''ファイル名の末尾に(i)をつける

    If Dir(fileSaveName) <> "" Then

        '保存ファイル名を取得

        fileSaveName_name = Dir(fileSaveName)

        '保存先のフォルダを取得

        fileSaveName_path = Replace(fileSaveName, fileSaveName_name, "")

        '保存ファイル名の末尾に(i)をつける

        k = 1

        Do While Dir(fileSaveName) <> ""

            fileSaveName = fileSaveName_path & Replace(fileSaveName_name, ".xlsx", "") & "(" & k & ")" & ".xlsx"

            k = k + 1

        Loop

       

   

       

    End If

Workbooks(3).Activate 'ひな形のコピーを作る

 With ActiveWorkbook.Worksheets(1)

         Range("N2").Value = Workbooks("名簿.csv").Worksheets(1).Cells(MyRange.Row, 4).Value 'no

         Range("M4").Value = invoiceday

         Range("O6").Value = Workbooks("名簿.csv").Worksheets(1).Cells(MyRange.Row, 2).Value 'Adress

         Range("O7").Value = Workbooks("名簿.csv").Worksheets(1).Cells(MyRange.Row, 3).Value 'tel

         Range("O8").Value = Workbooks("名簿.csv").Worksheets(1).Cells(MyRange.Row, 1).Value 'name

         Peopele = Workbooks("名簿.csv").Worksheets(1).Cells(MyRange.Row, 1).Value

        End With

 Workbooks(3).SaveAs fileSaveName

' ActiveWorkbook.Close

'   ActiveWorkbook.SaveAs SavePath & "\" & SaveName & Left(Peopele, 2) & ".xlsx"

         

'         Workbooks(2).Activate

'         ActiveWindow.SelectedSheets.Copy

'         wbNew = ActiveWorkbook.Name

'

        Workbooks("名簿.csv").Activate

        MyRange.Select

        Set MyRange = Cells.FindNext(MyRange)

    

    

'

''        Str = Str & Cells(MyRange.Row, 1).Value & Cells(MyRange.Row, 2).Value & Cells(MyRange.Row, 3).Value & Cells(MyRange.Row, 4).Value & vbLf

'

'

'        Workbooks(wbNew).Activate

'

'        With ActiveWorkbook.Worksheets(1)

'

'         Range("N2").Value = Workbooks("名簿.csv").Worksheets(1).Cells(MyRange.Row, 4).Value 'T_no

'         Range("M4").Value = invoiceday

'         Range("O6").Value = Workbooks("名簿.csv").Worksheets(1).Cells(MyRange.Row, 2).Value 'Adress

'         Range("O7").Value = Workbooks("名簿.csv").Worksheets(1).Cells(MyRange.Row, 3).Value 'tel

'         Range("O8").Value = Workbooks("名簿.csv").Worksheets(1).Cells(MyRange.Row, 1).Value 'name

'

'         Peopele = Workbooks("名簿.csv").Worksheets(1).Cells(MyRange.Row, 1).Value

'

'        End With

'

'

'

'         ActiveWorkbook.SaveAs SavePath & "\" & SaveName & Left(Peopele, 2) & ".xlsx"

'         ActiveWorkbook.Close

'         Workbooks(2).Activate

'         ActiveWindow.SelectedSheets.Copy

'         wbNew = ActiveWorkbook.Name

'

'        Workbooks("名簿.csv").Activate

'        MyRange.Select

'

'

'        Set MyRange = Cells.FindNext(MyRange)

        If FirstCell.Address = MyRange.Address Then Exit Do

    Loop

'''----------//Do

'    Debug.Print Str

'自身以外のworkbooksを閉じる

  For Each bk In Workbooks

    If Not (bk Is ThisWorkbook) Then

      bk.Close savechanges:=False

    End If

  Next

Set bk = Nothing

Set myPath = Nothing

Set mySubPath = Nothing

YearFolder = ""

FileName = ""

 myDay = ""

 wbNew = ""

myDayStr = ""

 ggg = ""

 e = ""

 mm = ""

 dd = ""

 myDay = ""

 myDayStr = ""

 LastRow = 0

Set MyRange = Nothing

Set FirstCell = Nothing

Set myFind = Nothing

SavePath = ""

SaveName = ""

Unload Me

End Sub