//失敗も勉強のうち ということで「失敗を消去せずに」置いておきます
//「ここでこういうことをすると失敗するんですね」 をご堪能いただきたく。
// 行頭の ’ がコメントアウトなので、ここにコードが続けばそこが失敗です
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
