Excelのひな形に ・指定の日付 ・宛名と住所電話番号、取引先コード を 入れて名前を付けて保存する（ループで人数分）

Excelのひな形に

　・指定の日付

　・宛名と住所電話番号、取引先コード

　を 入れて名前を付けて保存する（ループで人数分）

　※名簿はCSVで保存されている

　※あたらしいブックに保存する際はSavePath & "\" & SaveName &とし

　　指定のフォルダに保存させている

　※フォルダ構成は以下の画像の通り　

　　//名簿.csvは各フォルダには存在せず親フォルダに存在する

　

　

　//雑感：本当はListbook1で選択した人だけファイルを作る

　　　　　というロジックを考えていたのだが、複数選択可能な

　　　　　Listboxの選択項目自体を配列とすることは

　　　　　私の実力では不可能だった。

　　　　　というわけで、とりあえずグループ全員分をつくり

　　　　　いらないものは手動で消すという方法とした。

　　　　　ここが心残りでした。

　参考画像：...作成ボタンを押すと以下のコードが発動するしくみ。

　　

　　　　　

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

myDay = Format(Date, "gggemmdd")

myDayStr = CStr(myDay)

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

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

mm = StrConv(Mid(myDay, 5, 1), vbWide)

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

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

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

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 & "月" & "　" & "？？書　"

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

    Do

'        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(3).Activate

        MyRange.Select

        Set MyRange = Cells.FindNext(MyRange)

        If FirstCell.Address = MyRange.Address Then Exit Do

    Loop

'    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