週間作業予定表 VBAにて週別ファイル作成機能

 

こんなに気を張ってやるものでないけれど、、、、

前半の部分は前の投稿で説明しているので省略。かな

Dimがいっぱいとりあえずフォルダーの階層をひとつ一つ作成していくような流れにしてみました。

他の作成している人は一度に複数階層処理しているのですが、私はそこで何回もつまずいたので一つ一つ処理していく形をとりました。

PDFとエクセルのファイル両方を作成し別々のフォルダーに年月の階層を加えて保存するという流れにしてあります。私の勝手な判断で処理の流れとフォルダ番号が逆になっています。統一したかったけれど、これでとりあえず動くのでいいかなと思いなおしていません

。悪しからず

まぁ。。。仕事にしていないから許されるフローだろうけれどね。まとまりがないごちゃごちゃしたコードになっているけれど、ね

別途ファイルを公開する予定です。気が向いた時にやります。

お疲れさまでした。

ファイル公開..................
https://drive.google.com/file/d/1SwccHVX1JMHAVhv1Dk5xH5WIGH5sGX_Z/view?usp=sharing

Sub S211()

Dim zse As String

Dim zzz As Long

Dim i As Long

zse = Range("J9") & "月" & Range("J8") & "日～" & Range("K9") & "月" & Range("K8") & "日"

    ActiveSheet.Name = zse

    ThisWorkbook.Sheets(zse).Copy After:=Sheets(Sheets.Count)

    ActiveSheet.Name = zse & "1"

 Do While i <= 100

 Range("K11").Select

    Selection.Copy

   Range("B7").PasteSpecial xlPasteValues

zse = Range("J9") & "月" & Range("J8") & "日～" & Range("K9") & "月" & Range("K8") & "日"

    ActiveSheet.Name = zse

    ThisWorkbook.Sheets(zse).Copy After:=Sheets(Sheets.Count)

    ActiveSheet.Name = "処理前"

    i = i + 1

    Loop

    Application.DisplayAlerts = False

    ActiveSheet.Delete

   

    

    

    

Dim j As Long

Dim cona As Long

Dim ashna As String

Dim foruda As String

    Dim root As String

    Dim yyyy As String

    Dim mm As String

    Dim fold_pathA As String

    Dim fold_path As String

    Dim fold_pathY As String

    Dim fold_pathM As String

    Dim fold_pathP As String

    Dim fold_pathE As String

    

root = ThisWorkbook.Path

fold_pathA = root & "\勤務予定表\"

   If Dir(fold_pathA, vbDirectory) = "" Then

        MkDir fold_pathA

    End If

cona = Sheets.Count

For j = 1 To cona

Sheets(j).Select

ActiveSheet.Copy

yyyy = Range("J13")

mm = Range("J9")

fold_pathY = fold_pathA & yyyy & "年\"

   If Dir(fold_pathY, vbDirectory) = "" Then

        MkDir fold_pathY

    End If  '年別フォルダー

fold_pathM = fold_pathY & mm & "月\"

   If Dir(fold_pathM, vbDirectory) = "" Then

        MkDir fold_pathM

    End If  '月別フォルダー

fold_pathP = fold_pathM & "02_pdf\"

   If Dir(fold_pathP, vbDirectory) = "" Then

        MkDir fold_pathP

    End If 'PDF用フォルダー

fold_pathE = fold_pathM & "01_Excel\"

   If Dir(fold_pathE, vbDirectory) = "" Then

        MkDir fold_pathE

    End If 'Excel用フォルダー

ashna = ActiveSheet.Name

 

        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=fold_pathP & ashna & ".pdf"

        ActiveWorkbook.SaveAs fold_pathE & ashna & ".xlsx"

        ActiveWorkbook.Close

Next

 Application.DisplayAlerts = True

 MsgBox "処理が完了しました" & vbCrLf & "確認してください"

End Sub