vba ワークシートの名前を配列から命名する 配列は別ファイル（ここでは名簿.csv）から作成する

//十分なエラーテストは実施していません　ご参考程度に

 Sub makeP_Worksheet()

Dim targetFileName, targetFileName2, myPath, mePath As String

Dim flag As Boolean

Dim mySheetName(), LastRow As Variant

Dim cnt, i, FirstRow, myCnt As Long

Dim myRange, myObj, myFind As Range

Dim wb, wb2, myPeople As String

Dim myWb As Workbook

Dim myWbCnt As Long

On Error Resume Next

Dim bk As Workbook

  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)

mePath = ThisWorkbook.Path

targetFileName = mePath & "\" & "集計.xlsx"

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

Set wb = Workbooks.Open(targetFileName)

   myWbCnt = wb.Worksheets.Count

Set wb2 = Workbooks.Open(targetFileName2)

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

 

 

 If myWbCnt < LastRow Then

  wb.Worksheets.Add After:=Worksheets(1), Count:=LastRow

 End If

 Set myRange = Range(Cells(1, 1), Cells(LastRow, 1))

 Set myObj = myRange.Find(What:="*", SearchOrder:=xlByRows)

 If myObj Is Nothing Then

 

  Exit Sub

  

 End If

 

 wb.Worksheet(2).Name = myObj

' Debug.Print myObj & wb.Name

' Debug.Print myObj

 FirstRow = myObj

'  Debug.Print FirstRow

  

   Set myFind = myObj

   

   

 

 ReDim mySheetName(LastRow)

  mySheetName(0) = myObj

 wb.Worksheets(2).Name = mySheetName(0)

  

  

 

  i = 1

   Do

        '// 次を検索

        Set myFind = myRange.FindNext(After:=myFind)

        mySheetName(i) = myFind

'        Debug.Print myFind(i)

        wb.Worksheets(2 + i).Name = mySheetName(i)

        '// 検索不一致時はループを抜ける

        If myFind Is Nothing Then

            Exit Do

        End If

        '// 最初に検索されたセルが再検索された場合

        If myFind.Address = myObj.Address Then

            Exit Do

        End If

'        Debug.Print myFind

'        mySheetName(i) = myFind

        Debug.Print mySheetName(i)

        i = i + 1

    Loop

End Sub

改め 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

        flg = True

        Exit For

    End If

Next

If flg = False Then

    Workbooks.Open trgtFileName

End If

Set wb = Nothing

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 & "日"

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

  Dim TargetFiles As Files

 

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

    Set FSO = New FileSystemObject

    Set TargetFiles = FSO.GetFolder(SaveNameP).Files

    Dim fileSaveName As Variant

    Dim fileSaveName_name As String

    Dim fileSaveName_path As String

    Dim k As Integer

    Do

    

    

    

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

   

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

   

    If Dir(fileSaveName) <> "" Then

        

        fileSaveName_name = Dir(fileSaveName)

        

        fileSaveName_path = Replace(fileSaveName, fileSaveName_name, "")

        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 '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

 Workbooks(3).SaveAs fileSaveName

        Workbooks("名簿-外注費.csv").Activate

        MyRange.Select

        Set MyRange = Cells.FindNext(MyRange)

    

    

        If FirstCell.Address = MyRange.Address Then Exit Do

    Loop

  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

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

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

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

2024年（可変可能）フォルダを探して、さらに1月...12月のサブフォルダを作るVBA

’フォルダ作成ダブり処理に関わるエラートラップあり  

Sub MakeMonthFolder()

Dim myArrayMonth(12) As Variant

Dim i As Integer

Dim Filename As String

Dim myYear As Integer

Dim myPath, mySubPath, YearFolder As String

'myPath = Left(ThisWorkbook.path, InStrRev(ThisWorkbook.path, "\") - 1) & "\"

myPath = ThisWorkbook.path & "\"

YearFolder = CVar(Left(Date, 4)) + 1 '+1次年度、-1前年度

mySubPath = myPath & YearFolder & "-Excel" & "\"

 

'  Debug.Print mySubPath

 

For i = 1 To 12  

 myArrayMonth(i) = i & "月"

  If Dir(mySubPath & "\" & myArrayMonth(i), vbDirectory) = "" Then

  MkDir (mySubPath & "\" & myArrayMonth(i))

Else

' Debug.Print myPath & mySubPath & myArrayMonth(i) & ",フォルダの存在を確認しました"

Exit Sub

 End If

'

Next i

End Sub

値渡しでCombobox4.に日付を「今日から31まで」でAddItemとする

Private Sub ComboBox2_Change()

Dim Month As Integer

Month = UserForm1.ComboBox2.Value

Call LeapYear(Month)

End Sub

Private Sub LeapYear(Month As Integer)

Dim ComboBox4 As Integer

Dim myArray() As Long

Dim i As Integer

UserForm1.ComboBox4.Clear

ReDim myArray(31)

Dim thisDay As Date

Dim myDay As String

Dim LngDay As Long

thisDay = Format(Date, "yyyy/mm/dd")

myDay = Mid(CStr(thisDay), 9, 2)

LngDay = CLng(myDay)

 

 Select Case Month

 Case 1, 3, 5, 7, 8, 10, 12

 For i = 0 To 31

 

  myArray(i) = LngDay + i

  

   If myArray(i) > 31 Then

   

   Exit Sub

   

   Else

   

    UserForm1.ComboBox4.AddItem myArray(i)

  

  End If

  

 

  Next i

   UserForm1.ComboBox4.AddItem myArray(i)

   

 Case 4, 6, 9, 11

 

 

 For i = 0 To 30

 

  myArray(i) = LngDay + i

  

   If myArray(i) > 30 Then

   

   Exit Sub

   

   Else

   

    UserForm1.ComboBox4.AddItem myArray(i)

  

   End If

 

  Next i

 

 

 Case Else

 For i = 0 To 28

 

  myArray(i) = LngDay + i

  

   If myArray(i) > 28 Then

   

   Exit Sub

   

   Else

   

    UserForm1.ComboBox4.AddItem myArray(i)

 

  End If

 

  Next i

End Select

End Sub

雑感：作った後に考えました。「書類をためる人」という吾人がいらっしゃることを

　　　半年前の話なんて困りますよー　という...

　　　やっぱり日付は1-31が都合がいいかな。

雑感2：31日まで、30日まで、28日まで、うるう年29日まで。

　　　　日付は4つのバリエーションがあります。

　　　　の後ほど考えます

ExcelファイルをPDFファイルに自動変換するVBA

 #Excelファイル　を　#pdfに自動変換　する　#VBAをつくれないだろうかな、と思って作成。簡易的なものなのでエラーテストを十分していないのでご利用は自己責任です。

できてうれしいので公開ときます。ネット上のvba職人さん方々に敬意を表して。

Sub pdf作成()
Dim myPath As String
Dim FileInt As Long
Dim SetPath As String
Dim myFilename As String

Application.DisplayAlerts = False '
myPath = ThisWorkbook.Path
FileInt = 0
SetPath = Dir(myPath & "\" & "*.xls")
Do While SetPath <> ""
FileInt = FileInt + 1

Workbooks.Open Filename:=ThisWorkbook.Path & "\" & SetPath
myFilename = Left(SetPath, Len(SetPath) - 4)

ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & myFilename, OpenAfterPublish:=False
ActiveWorkbook.Close

SetPath = Dir()
Loop
Application.DisplayAlerts = True

End Sub

最終稿：

Sub pdf作成() Dim myPath As String Dim FileInt As Long Dim SetPath As String Dim myFilename As String Dim OriginalPath, OriginalPathName As String On Error Resume Next Application.DisplayAlerts = False myPath = ThisWorkbook.Path FileInt = 0 SetPath = Dir(myPath & "\" & "*.xls") OriginalPath = ThisWorkbook.Name OriginalPathName = Left(OriginalPath, Len(OriginalPath) - 4) Do While SetPath <> "" FileInt = FileInt + 1 Workbooks.Open Filename:=ThisWorkbook.Path & "\" & SetPath myFilename = Left(SetPath, Len(SetPath) - 4) If myFilename = OriginalPathName Then Exit Sub Else End If Debug.Print OriginalPathName ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & myFilename, OpenAfterPublish:=False ActiveWorkbook.Close SetPath = Dir() Loop Application.DisplayAlerts = True End Sub

後日談：Do while文つかっているのだから、IF分を中に噛ませないでDowhileの条件で

　　　　大丈夫じゃないか？とおもったのですが、実際やってみるとうまくいかないんです。

　　　　こういうお手盛りなところが基本設計がよろしくないというところで

　　　　しかしいまのところこの程度のことしかできない...　ご笑納ください

Git-Hub

https://github.com/sjgiken/Excel-PDF-VBA