作業ファイルが不確定時の配列ループ

Sub シート収集()

html
1    Dim filePath As Variant
2    filePath = Application.GetOpenFilename( _
3    FileFilter:="Excelブック(*.xlsx;*.xlsm;*.xls),*.xlsx; *.xlsm; *.xls", MultiSelect:=True)
4    
5    Dim file As Variant
6    Dim wb As Workbook
7    Dim i As Long
8    Dim name As Variant
9    name = Array("01北海道", "02東京", "03大阪", "名古屋", "05福岡")
10
11        For Each file In filePath
12        Set wb = Workbooks.Open(file)
13        If Not wb Is Nothing Then
14        Select Case True
15            Case wb.name = name(i) & ".xlsx"
16                wb.Sheets(2).name = name(i) & " 内訳"
17                wb.Sheets(2).Copy Before:=ThisWorkbook.Worksheets(1)
18            End Select
19            wb.Close False
20        End If
21    Next file
22End Suｂ

**以下の作業は、毎日行われ、開くファイルの数は作業する日によって変わるとします。

**
選択ダイアログで複数ファイルを選択し、thisworkbookに開いたファイルのシートを集めていくというマクロです。

常に配列の01～05全てのファイルと開くとすると問題なく動くのですが、作業するファイルは毎日変わる（01と02のみ動かしたい時もあれば、03と04と05のみ動かしたい時もある）ため、うまくいきません。

html
1            Case wb.name = name(i) & ".xlsx"
2                wb.Sheets(2).name = name(i) & " 別紙"
3                wb.Sheets(2).Copy Before:=ThisWorkbook.Worksheets(1)
4            End Select

例えば02東京と03大阪のファイルを選択して、マクロを動かすと
name(0)である"01北海道"が該当しないため、マクロがなにもせず終わってしまいます。

もちろん、全てのCaseを書けば問題が解決することはわかりますが、実際の作業ファイルは40程あるため、メンテナンス性を考えて短くしたいと思っています。

どうかご教示いただけたらと思います。
よろしくお願いします。

行動規範の内容に同意します

回答4件

大変申し訳ありません。皆様の助言をいただきもう一度精査したところ以下のコードでうまく動きました。

Sub シート収集()

    Dim filePath As Variant
    filePath = Application.GetOpenFilename( _
    FileFilter:="Excelブック(*.xlsx;*.xlsm;*.xls),*.xlsx; *.xlsm; *.xls", MultiSelect:=True)
    
    Dim file As Variant
    Dim wb As Workbook
    Dim myArray As Variant
    Dim name As Variant
    name = Array("01北海道", "02東京", "03大阪", "04名古屋", "05福岡")
    Dim i As Long
    
    For Each file In filePath
        Set wb = Workbooks.Open(file)
        For Each myArray In name
            Select Case True
                Case wb.name = myArray & ".xlsx"
                    wb.Sheets(2).name = myArray & " 内訳"
                    wb.Sheets(2).Copy Before:=ThisWorkbook.Worksheets(1)
                End Select
        Next myArray
        wb.Close False
    Next file
End Sub

ループするコードが一つ足りなかっただけでした。
自己解決にはなりましたが、皆様の助言で解決に向かいました。
最も私に考える余地をくださった方にベストアンサーをあげたいと思います。
本当にありがとうございました。

投稿2020/10/12 15:03

編集2020/10/12 15:05

Dis

総合スコア19

補足要求です。
選択したファイルが決まれば、コピー元のシート名は必ず決まるのでしょうか。
それとも、コピー元ブックのシートの左から２番目固定で、そのシート名をコピーし、
コピー先のシート名はコピー元のブック名＋”XXX”のようにするのですか。（XXXはコピー元のブック名ににより決まる）
又、その場合、１つの選択したファイルから、２つ以上のシートをコピーする場合もあるのでしょうか。

投稿2020/10/12 13:15

編集2020/10/12 13:30

tatsu99

総合スコア5493

端的にいうと、

選択ダイアログで複数のファイル（.xlsxブック）を選択する。
選択したブック名が "01北海道", "02東京", "03大阪", "名古屋", "05福岡"のどれかだったら
そのブックの2番目のシートを、マクロを実行しているブックの先頭にコピーする。

ということがご希望のことでしょうか。
もし、そうなら、下記のコードで。
違うなら、どの辺が違うのか、具体的に説明してください。

Sub シート収集()
    Dim filePath As Variant
    filePath = Application.GetOpenFilename( _
               FileFilter:="Excelブック(*.xlsx;),*.xlsx;", MultiSelect:=True)

    Dim file As Variant
    Dim wb As Workbook
    Dim wbName As String

    For Each file In filePath
        Set wb = Workbooks.Open(file)
        If Not wb Is Nothing Then
            wbName = Replace(wb.name, ".xlsx", "") '拡張子".xlsx"を削除
            Select Case wbName
            Case "01北海道", "02東京", "03大阪", "04名古屋", "05福岡"
                wb.Sheets(2).name = wbName & " 内訳"
                wb.Sheets(2).Copy Before:=ThisWorkbook.Worksheets(1)
            End Select
            wb.Close False
        End If
    Next file
End Sub

投稿2020/10/12 13:08

編集2020/10/13 00:21