Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10全般 : Excel 2010)
特定の文字が含まれるシートを検索して、ブック保存したい
投稿日時: 21/09/15 22:32:17
投稿者: さくら03

ご教示お願い致します。
 
60シート程あるファイルから特定の文字が含まれるシートを検索して、ブック保存したいです。
 
キーワードシートに「りんご」、「みかん」等の文字が10行程入力してあります。
その文字が含まれるシートが複数あるので、りんごで検索したなら、ファイル名「りんご.xlsx」で保存したいです。
 
下記を実行すると「インデックスが有効範囲にありません」というエラーになります。
解決策が見つからず困っています。ご教示お願い致します。
 
 
Sub テスト()
    Dim Sh As Worksheet
    Dim ArrayShName() As String
    Dim z As Long
    Dim i As Integer
    Dim savePath As String
    Dim KEY As Variant '特定の文字は、キーワードシートのA列の値
       
    i = 1
     
    ReDim ArrayShName(0)
  
 Do Until Sheets("キーワード").Cells(i, 1) = ""
 
    KEY = Sheets("キーワード").Cells(i, 1)
    savePath = ThisWorkbook.Path & "\" & KEY & ".xlsx"
     
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Name Like KEY & "*" Then
            ReDim Preserve ArrayShName(z)
            ArrayShName(z) = Sh.Name
            z = z + 1
        End If
    Next Sh
     
     If ArrayShName(0) = "" Then Exit Sub
    
    Worksheets(ArrayShName).Move
    ActiveWorkbook.SaveAs savePath
    ActiveWorkbook.Close
  
    i = i + 1
 Loop
 
End Sub

回答
投稿日時: 21/09/15 22:49:56
投稿者: WinArrow
投稿者のウェブサイトに移動

>下記を実行すると「インデックスが有効範囲にありません」というエラーになります。
どの行でエラーになるのか?
確認しましょう。
 
おそらく
> Worksheets(ArrayShName).Move
の行だと思いますが、
 
>ArrayShName
は配列ですから、この指定はNGですよね?
 
ところで、例えば「リンゴA]「リンゴB]というシートがあった場合、
シート名が2つになります。
でも、出力するファイルは1つでよいのですか?

投稿日時: 21/09/15 23:17:01
投稿者: さくら03

WinArrowさま
ご返信ありがとうございます。
 
> Worksheets(ArrayShName).Move
ご指摘の箇所でエラーになります。
キーワードシート1行目「りんご」は動くのですが、2行目の「みかん」でエラーになります。
この書き方はNGなのですね。勉強不足で分かりませんでした。
 
>シート名が2つになります。
>でも、出力するファイルは1つでよいのですか?
→はい、ファイル1つでよいです。
 

回答
投稿日時: 21/09/16 07:50:18
投稿者: WinArrow
投稿者のウェブサイトに移動

修正案1
 
> Dim ArrayShName() As String

    Dim ArrayShName
 
これで、対応できるかは、若干疑問ですが、試してみてください。
 
修正案2
> Worksheets(ArrayShName).Move

    Worksheets(Array(ArrayShName)).Copy
 
※Move→Copyは、もしかして、シートが0になることを想定した場合の予防策です。

回答
投稿日時: 21/09/16 15:47:55
投稿者: simple

エラーになったときの
ArrayShNameの状況(配列ならその大きさとか値など)はどうなっているのか示してください。
議論の前提なので。
ローカルウインドウを見ればわかると思います。

回答
投稿日時: 21/09/16 17:33:23
投稿者: WinArrow
投稿者のウェブサイトに移動

>キーワードシート1行目「りんご」は動くのですが
たまたま、動いただけのこと。
 
このとき
ArrayShNameの配列は、1つだけでしょう。
Debug.print UBound(ArrayShName)
で確認すると分かります。
→結果:0のはず
 

回答
投稿日時: 21/09/17 10:14:46
投稿者: simple

事実確認への回答コメントがないので、追記します。
 
二つ目のKEYに対して実行するとき、
ArrayShNameが初期化されていないので、一回目のキーが残っているのではないですか?
事実関係を観察すればすぐにわかるはずです。
そのシートは既に移動済ですから、
「インデックスが有効範囲にありません」とエラーになっているのでしょう。
 
対応策としては、Do ループの最初で、二行追加すればよいと思います。

    Do Until Sheets("test").Cells(i, 1) = ""
        ReDim ArrayShName(0)  '■追加
        z = 0                 '■追加

回答
投稿日時: 21/09/17 10:19:41
投稿者: simple

追加ですが、
If ArrayShName(0) = "" Then Exit Sub
は一考の余地があるでしょう。
対応するシートがないKEYが一つでもあると、
それ以降のKEYに関する処理を飛ばして終了してしまいますよ。
 

        If ArrayShName(0) <> "" Then
            Worksheets(ArrayShName).Move
            ActiveWorkbook.SaveAs savePath
            ActiveWorkbook.Close
        End If
などとすると良いのでは?

回答
投稿日時: 21/09/17 10:40:08
投稿者: WinArrow
投稿者のウェブサイトに移動

simple さんの引用:
追加ですが、
If ArrayShName(0) = "" Then Exit Sub
は一考の余地があるでしょう。
対応するシートがないKEYが一つでもあると、
それ以降のKEYに関する処理を飛ばして終了してしまいますよ。
 
        
      If ArrayShName(0) <> "" Then
            Worksheets(ArrayShName).Move
            ActiveWorkbook.SaveAs savePath
            ActiveWorkbook.Close
        End If

などとすると良いのでは?

 
配列変数なのに、配列を意識しないことが問題なんで
以下を推奨します。
    For Z = LBound(ArrayShName) To UBound(ArrayShName)
        If ArrayShName(Z) <> "" Then
            Worksheets(Array(ArrayShName)).Move
            ActiveWorkbook.SaveAs savePath
            ActiveWorkbook.Close False
        End If
    Next

但し、.Moveが適切かは、状況が分からいので疑問が残る。
 
 
 

回答
投稿日時: 21/09/17 12:06:22
投稿者: simple

21/09/17 10:14:46の発言で、当方のテスト中のコードを間違って提示してしまったので
改めて全体を載せます。これで動作すると思います。(シート名だけですが)
 

Sub テスト()
    Dim Sh As Worksheet
    Dim ArrayShName() As String
    Dim z As Long
    Dim i As Integer
    Dim savePath As String
    Dim KEY As Variant    '特定の文字は、キーワードシートのA列の値

    i = 1
    Do Until Sheets("キーワード").Cells(i, 1) = ""
        ReDim ArrayShName(0)
        z = 0
        KEY = Sheets("キーワード").Cells(i, 1)
        savePath = ThisWorkbook.Path & "\" & KEY & ".xlsx"

        For Each Sh In ThisWorkbook.Worksheets
            If Sh.Name Like KEY & "*" Then
                ReDim Preserve ArrayShName(z)
                ArrayShName(z) = Sh.Name
                z = z + 1
            End If
        Next Sh

        If ArrayShName(0) <> "" Then
            Worksheets(ArrayShName).Move
            ActiveWorkbook.SaveAs savePath
            ActiveWorkbook.Close
        End If
        i = i + 1
    Loop
End Sub
"キーワード"シートは移動の対象にならないことが前提ですw。
WinArrowさん、すみません、おっしゃることに追いつけませんでした。

投稿日時: 21/09/18 18:49:25
投稿者: さくら03

お二人ともご教示ありがとうございました!
勉強になりました。返信が遅くなり申し訳ありません。
教えていただいたコードでやりたい事ができました!!!