ブック内の複数のシートを、シート名で仕分けてグループに分類し、そのグループごとにPDFにしたい。

Question

〇やりたいこと
1枚のブックにシートが10枚あるとします。
それぞれ、シート名の先頭３文字には、100 or 200 or 300　の　いずれかが 書かれております。
そのシート名の先頭３文字を元にシートを仕分けて、それぞれPDFにしたいです。
（例：100が先頭３文字ついているシートだけを１つのPDFファイルにし、ファイル名は 100.pdf　としたい。　200、300も同様。この3桁の数字は、取引先のコードを想定しております）

〇自分で試したこと
配列変数を3つ用意（ary100,ary200,ary300)する。初期の要素数は、１とする(1 to 1　の1始まり）。
そのシート名の先頭3文字を判定して（left関数を使用)、該当する配列に入れる。
入れたら、配列の要素数をredim preserve　+1　足していく。

一通り終わったら、それぞれ、ary100().Exportasfixedformat でPDF化。

上記ではできませんでした。
どなたか、アドバイスをお願いします。

コード
Sub macro()

Dim ary100() As String
Dim ary200() As String
Dim ary300() As String

ReDim ary100(1 To 1) As String
ReDim ary200(1 To 1) As String
ReDim ary300(1 To 1) As String

Dim ws As Worksheet
For Each ws In Sheets

    Select Case Left(ws.Name, 3)
        Case 100
         ary100(UBound(ary100)) = ws.Name
    
        ReDim Preserve ary100(1 To UBound(ary100) + 1)
        
        Case 200
         ary200(UBound(ary200)) = ws.Name
        ReDim Preserve ary200(1 To UBound(ary200) + 1)
        
        Case 300
        ary300(UBound(ary300)) = ws.Name
        ReDim Preserve ary300(1 To UBound(ary300) + 1)
        
    End Select
 Next

 Worksheets(ary100).Select
 ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\Users\awga1\Documents\PDF保管\100.pdf"
     
Worksheets(ary200).Select
 ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\Users\awga1\Documents\PDF保管\200.pdf"

Worksheets(ary300).Select
 ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\Users\awga1\Documents\PDF保管\300.pdf"
End Sub

Answer 1

excelのvbaで複数シートを1ファイルのpdfにする - Qiita

Exportasfixedformat で複数シートをPDFにする場合は、対象シートをセレクトしてからActiveSheetに対してExportasfixedformatを実行する必要があるようです。

コード例

Sub macro()

    Dim st100 As String
    Dim st200 As String
    Dim st300 As String


    Dim ws As Worksheet
    For Each ws In Sheets
        Select Case Left(ws.Name, 3)
        Case 100
            st100 = st100 & " " & ws.Name
        Case 200
            st200 = st200 & " " & ws.Name
        Case 300
            st300 = st300 & " " & ws.Name
        End Select
    Next
    
    Sheets(Split(Trim(st100))).Select
    ActiveSheet.ExportAsFixedFormat Type:=0, Filename:="C:\test\100.pdf"
    
    Sheets(Split(Trim(st200))).Select
    ActiveSheet.ExportAsFixedFormat Type:=0, Filename:="C:\test\200.pdf"

    Sheets(Split(Trim(st200))).Select
    ActiveSheet.ExportAsFixedFormat Type:=0, Filename:="C:\test\300.pdf"

End Sub

おまけ
配列とForループでシンプルにした例

Public Sub test()
    Dim WSs(1 To 3) As String

    Dim ws As Worksheet, i As Long
    For Each ws In Sheets
        i = Left(ws.Name, 1)
        WSs(i) = WSs(i) & " " & ws.Name
    Next
    
    For i = 1 To UBound(WSs)
      Sheets(Split(Trim(WSs(i)))).Select
      ActiveSheet.ExportAsFixedFormat Type:=0, Filename:="C:\test\" & i & "00.pdf"
    Next
End Sub

Comments

[robben]

ありがとうございます。
ご提案いただいた、コードを見て、自分のコードを修正して、試しましたがうまくいきませんでした。

（変数の型をstringに変更し、worksheet.nameを挿入するように書きましたがWorksheets(ary100).Selectの部分に『インデックスが有効範囲にありません』と出ます）

私のコードだと何がいけないでしょうか？

[hatena19]

下記でどうでしょう。

If UBound(ary100) > 1 Then
ReDim Preserve ary100(1 To UBound(ary100) - 1)
Worksheets(ary100).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\Users\awga1\Documents\PDF保管\100.pdf"
End If

Answer 2

こんな感じでどうでしょうか。

Sub macro()

Dim ary100()
Dim ary200()
Dim ary300()

Dim i100, i200, i300

Dim ws As Worksheet
For Each ws In Sheets

    Select Case Left(ws.Name, 3)
        Case 100
        ReDim Preserve ary100(i100)
        ary100(i100) = ws.Name
        i100 = i100 + 1

        Case 200
        ReDim Preserve ary200(i200)
        ary200(i200) = ws.Name
        i200 = i200 + 1

        Case 300
        ReDim Preserve ary300(i300)
        ary300(i300) = ws.Name
        i300 = i300 + 1

    End Select
 Next
 
 If i100 > 0 Then
    Worksheets(ary100).Copy
    With ActiveWorkbook
       .ExportAsFixedFormat Type:=0, Filename:="100.pdf"
       .Close False
    End With
 End If
 If i200 > 0 Then
    Worksheets(ary200).Copy
    With ActiveWorkbook
       .ExportAsFixedFormat Type:=0, Filename:="200.pdf"
       .Close False
    End With
 End If
 If i300 > 0 Then
    Worksheets(ary300).Copy
    With ActiveWorkbook
       .ExportAsFixedFormat Type:=0, Filename:="300.pdf"
       .Close False
    End With
 End If

End Sub

---

＜追記＞別解を考えてみました。

Sub macro2()
 
 Dim i
 ReDim wsNames(1 To Worksheets.Count)
 For i = 1 To Worksheets.Count
  wsNames(i) = Worksheets(i).Name
 Next
 
 Dim v, ary
 For Each v In Array("100", "200", "300")
    ary = Filter(wsNames, v)
    If UBound(ary) > -1 Then
       Worksheets(ary).Select
       ActiveSheet.ExportAsFixedFormat Type:=0, Filename:=v & ".pdf"
    End If
 Next
 
End Sub

Sub macro3()

 Dim dic 'As Scripting.Dictionary
 Set dic = CreateObject("Scripting.Dictionary")

 Dim ws As Worksheet, tCode As String
 For Each ws In Sheets
    tCode = Left(ws.Name, 3)
    dic(tCode) = dic(tCode) & " " & ws.Name
 Next

 Dim k
 For Each k In dic
   Worksheets(Split(Trim(dic(k)))).Select
   ActiveSheet.ExportAsFixedFormat Type:=0, Filename:=k & ".pdf"
 Next
 
End Sub

Comments

[robben]

ありがとうございます。
ご提案いただいた、コードを見て、自分のコードを修正して、試しましたがうまくいきませんでした。

（変数の型をstringに変更し、worksheet.nameを挿入するように書きましたがWorksheets(ary100).Selectの部分に『インデックスが有効範囲にありません』と出ます）

私のコードだと何がいけないでしょうか？

[jinoji]

シート名を配列に格納してから配列を１つ拡張する、という順番で処理しているので、
ループを抜けたあとは配列の最後の要素が空になっていて、(100A,100B, 空 ）
シート名が空のシートをSelectなんてできないからエラーになるのだと思います。

[robben]

ありがとうございます。なるほど。おっしゃる通りでした。
selectに関しては配列が１つでも空があると、selectできないということですね？
なので、下記を、for eachのループの下に書いて、３つの各配列の一番最後の要素を削除するようにしました。これで、うまくいきました。
たぶん、やり方は、複数あると思うのですが、やり方としては、これも間違っていないでしょうか？

ReDim Preserve ary100(1 To UBound(ary100) - 1)
ReDim Preserve ary200(1 To UBound(ary200) - 1)
ReDim Preserve ary300(1 To UBound(ary300) - 1)