none
ループ中にデータ重複時のみ挙動を変更させたい RRS feed

  • 質問

  • ■質問

    ループ制御時に値の重複を確認し、重複した時のみ挙動を変更させるにはどうしたらよいでしょうか。

    ■前提状況

    1つのWorkbookで複数の請求書データを管理しています。
    必要に応じて一時的ににシートを生成し、PDFで保存しています。これを自動化しようとしています。

    1シート毎に1PDF(1枚の請求書につき1つのPDF)を出力します。

    そこで次のコードを書き、一通り希望の動作ができました。

    Sub ExportPDF() Dim sh As Worksheet For Each sh In ActiveWindow.SelectedSheets     sh.Select     ActiveSheet.ExportAsFixedFormat _ Type:=xlTypePDF, _         Filename:=Range("件名").Value, _ Quality:=xlQualityMinimum, _
            IncludeDocProperties:=False, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=True
    Next sh

    End Sub

    →これで現在のシート(複数シートを選択した場合は作業グループ)をPDF出力できます。@Desktop

    ■問題点

    問題は、選択した請求書に同じ件名がある場合、つまり「Range("件名").Value」の値に重複がある場合、
    同名保存のトラブルが発生することです。
    かといって、数字をカウントして常に「◯◯1.pdf」「◯◯2.pdf」・・・とするのも避けたいですし、
    そもそもの件名を重複させないようなルールとするのも避けたいです。

    恐らく配列を使うのだと思いますが(間違いでしょうか)、次の使い方がまだ分からず苦戦しています。

    ・任意の複数のシートに存在する特定のセルの値を格納する方法。
    ・格納された複数の値の中に任意の値が存在するかを確認する方法。



    ■理想動作

    理想としては、選択されたシートに存在する件名が重複した場合にのみ、
    「◯◯1.pdf」「◯◯2.pdf」・・・とナンバリングしたいのです。

    ※ 後続のPDFのみナンバリングされていても構いません。例「◯◯.pdf」「◯◯2.pdf」
    ※ 重複のあるシートと同時に重複のないシートも選択されている場合、
      重複のないシートへのナンバリングは避けたいです。例「◯◯1.pdf」「◯◯2.pdf」「△△.pdf」

    2014年10月2日 10:08

回答

  • こんな

    ’既にファイルが存在していても上書きしていい場合
    Sub ExportPDF()
        Dim colNameGroups As New Collection'件名毎にするコレクション
        Dim colSheets As Collection'同じ件名のシートを入れておくコレクション
        Dim sh As Worksheet
        Dim name As String
        For Each sh In ActiveWindow.SelectedSheets
            name = sh.Range("件名").Value
            name = Trim(name)
            If (Len(name) > 0) Then
                Set colSheets = Nothing
                On Error Resume Next
                Set colSheets = colNameGroups.Item(name)
                On Error GoTo 0
                If (colSheets Is Nothing) Then
                    'この件名を入れておくコレクションがまだないなら新しく作る
                    Set colSheets = New Collection
                    Call colNameGroups.Add(colSheets, Key:=name)
                End If
                Call colSheets.Add(sh)'この件名のコレクションに入れる
            End If
        Next sh
        
        Dim number As Integer
        For Each colSheets In colNameGroups'件名別に分けられているコレクションから順に取り出す
            number = 1
            
            For Each sh In colSheets'同じ件名のシートを取り出す
                name = sh.Range("件名").Value
                If (colSheets.Count > 0) Then
                    '同じ件名のシートが複数あるなら件名に連番をつける
                    name = name & number
                    number = number + 1
                End If
                
                sh.ExportAsFixedFormat _
                    Type:=xlTypePDF, _
                    Filename:=name, _
                    Quality:=xlQualityMinimum, _
                    IncludeDocProperties:=False, _
                    IgnorePrintAreas:=False, _
                    OpenAfterPublish:=True
            Next
        Next
    End Sub

    ’同じファイル名があった場合は別の番号を付加する場合(ただしタイミングによっては上書きしてしまう可能性はある)
    Sub ExportPDF2()
        Dim colNameGroups As New Collection
        Dim colSheets As Collection
        Dim sh As Worksheet
        Dim name As String
        For Each sh In ActiveWindow.SelectedSheets
            name = sh.Range("件名").Value
            name = Trim(name)
            If (Len(name) > 0) Then
                Set colSheets = Nothing
                On Error Resume Next
                Set colSheets = colNameGroups.Item(name)
                On Error GoTo 0
                If (colSheets Is Nothing) Then
                    Set colSheets = New Collection
                    Call colNameGroups.Add(colSheets, Key:=name)
                End If
                Call colSheets.Add(sh)
            End If
        Next sh
        
        Dim number As Integer
        For Each colSheets In colNameGroups
            number = 2
            
            For Each sh In colSheets
                name = sh.Range("件名").Value
                
                If (Dir(name & ".pdf") <> "") Then
                    'ファイルにすでにある場合
                    Do
                        '番号つきの名前のファイルを調べて重複しない番号を探す
                        name = sh.Range("件名").Value & number & ".pdf"
                        number = number + 1
                    Loop While (Dir(name) <> "")
                End If
    
                sh.ExportAsFixedFormat _
                    Type:=xlTypePDF, _
                    Filename:=name, _
                    Quality:=xlQualityMinimum, _
                    IncludeDocProperties:=False, _
                    IgnorePrintAreas:=False, _
                    OpenAfterPublish:=True
            Next
        Next
    End Sub


    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

    • 回答としてマーク junnny 2014年10月3日 10:45
    2014年10月2日 14:53

すべての返信

  • Excelにおける件名の重複だけ調べてもダメではないでしょうか? 例えば、

    >例「◯◯1.pdf」「◯◯2.pdf」「△△.pdf」

    と書かれていますが、△△.pdfを書き出すフォルダに、既に同名のファイルが存在している場合は、どのようにする仕様なのでしょうか?

    問題は件名の重複ではなく、pdfファイル名の重複を避けたいということではないでしょうか?
    であれば、pdfファイルを書き出す前に、VBAのDIR関数で書き出そうとしているファイル名の存在チェックをし、存在しなくなるまで△△の後にシーケンス番号を付加したファイル名を試し、存在しなくなった時点でファイルを書き出せば良いと思います。例えば、△△.pdf, △△(1).pdf, △△(2).pdfが既に存在しているならば、△△(3).pdfというファイル名で書き出すことになります。

    (追記)
    ちなみにユニークな請求書番号はないのでしょうか? これがあれば、「件名 + 請求書番号」とすれば、件名が同じでもファイル名はユニークになります。ただし、書き出す際に既に同じファイル名が存在している場合がありますので、やはり、DIR関数による存在チェックは必要です。


    ★良い回答には回答済みマークを付けよう! わんくま同盟 MVP - Visual C# http://d.hatena.ne.jp/trapemiya/

    2014年10月2日 14:16
    モデレータ
  • こんな

    ’既にファイルが存在していても上書きしていい場合
    Sub ExportPDF()
        Dim colNameGroups As New Collection'件名毎にするコレクション
        Dim colSheets As Collection'同じ件名のシートを入れておくコレクション
        Dim sh As Worksheet
        Dim name As String
        For Each sh In ActiveWindow.SelectedSheets
            name = sh.Range("件名").Value
            name = Trim(name)
            If (Len(name) > 0) Then
                Set colSheets = Nothing
                On Error Resume Next
                Set colSheets = colNameGroups.Item(name)
                On Error GoTo 0
                If (colSheets Is Nothing) Then
                    'この件名を入れておくコレクションがまだないなら新しく作る
                    Set colSheets = New Collection
                    Call colNameGroups.Add(colSheets, Key:=name)
                End If
                Call colSheets.Add(sh)'この件名のコレクションに入れる
            End If
        Next sh
        
        Dim number As Integer
        For Each colSheets In colNameGroups'件名別に分けられているコレクションから順に取り出す
            number = 1
            
            For Each sh In colSheets'同じ件名のシートを取り出す
                name = sh.Range("件名").Value
                If (colSheets.Count > 0) Then
                    '同じ件名のシートが複数あるなら件名に連番をつける
                    name = name & number
                    number = number + 1
                End If
                
                sh.ExportAsFixedFormat _
                    Type:=xlTypePDF, _
                    Filename:=name, _
                    Quality:=xlQualityMinimum, _
                    IncludeDocProperties:=False, _
                    IgnorePrintAreas:=False, _
                    OpenAfterPublish:=True
            Next
        Next
    End Sub

    ’同じファイル名があった場合は別の番号を付加する場合(ただしタイミングによっては上書きしてしまう可能性はある)
    Sub ExportPDF2()
        Dim colNameGroups As New Collection
        Dim colSheets As Collection
        Dim sh As Worksheet
        Dim name As String
        For Each sh In ActiveWindow.SelectedSheets
            name = sh.Range("件名").Value
            name = Trim(name)
            If (Len(name) > 0) Then
                Set colSheets = Nothing
                On Error Resume Next
                Set colSheets = colNameGroups.Item(name)
                On Error GoTo 0
                If (colSheets Is Nothing) Then
                    Set colSheets = New Collection
                    Call colNameGroups.Add(colSheets, Key:=name)
                End If
                Call colSheets.Add(sh)
            End If
        Next sh
        
        Dim number As Integer
        For Each colSheets In colNameGroups
            number = 2
            
            For Each sh In colSheets
                name = sh.Range("件名").Value
                
                If (Dir(name & ".pdf") <> "") Then
                    'ファイルにすでにある場合
                    Do
                        '番号つきの名前のファイルを調べて重複しない番号を探す
                        name = sh.Range("件名").Value & number & ".pdf"
                        number = number + 1
                    Loop While (Dir(name) <> "")
                End If
    
                sh.ExportAsFixedFormat _
                    Type:=xlTypePDF, _
                    Filename:=name, _
                    Quality:=xlQualityMinimum, _
                    IncludeDocProperties:=False, _
                    IgnorePrintAreas:=False, _
                    OpenAfterPublish:=True
            Next
        Next
    End Sub


    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

    • 回答としてマーク junnny 2014年10月3日 10:45
    2014年10月2日 14:53
  • trapemiyaさん

    返信ありがとうございます。

    >既に同名のファイルが存在している場合は、どのようにする仕様なのでしょうか?

    例示にある通り「◯◯1.pdf」「◯◯2.pdf」または「◯◯.pdf」「◯◯2.pdf」という様にする予定です。
    数字の表記は「2」、「(2)」、「_2」など、見やすいものを考えてます。

    >問題は件名の重複ではなく、pdfファイル名の重複を避けたいということではないでしょうか?

    はいその通りです。今回の趣旨は「問題点」で示した通り同名保存のトラブルを避けることにあります。

    >pdfファイルを書き出す前に、VBAのDIR関数で書き出そうとしているファイル名の存在チェック

    これは確かにそうですね。ずっとExcel側の値をどう扱うかしか考えていませんでした。
    ただ、ファイルが多いディレクトリだと時間が掛かるかもしれませんので、他に有効な策がない場合に検討してみたいと思います。
    とても良いヒントをいただきました。ありがとうございます。

    >ユニークな請求書番号はないのでしょうか?

    ありますが、諸事情でファイル名には使用しません。恐らく普通ならこれでも解決できそうではありますね。
    その代わり、実際のファイル名には作成日を入れる予定です
    → Format(Date, "yymmdd") & Range("件名").Value

    こちら側の事情になりますが、通常は件名重複の可能性が低いため、同日に同じ件名のものがあるというのは「意図的に同案件(一連の案件)に対して複数作成した」という事になります。それは認識されているので良いのですが、たとえば同日に、あるいは手動でファイル名の日付部分を変更した場合、作成した事を忘れたり処理済みのファイルが残っていたりすると、認識されていない状態で作業する事になりかねず、危ういと考えています。であれば同日同件名の案件であれば上書きしてしまった方が問題は起きないと考えています。ただこれも実運用上のフィードバック次第で変更するかも知れませんが。

    • 編集済み junnny 2014年10月3日 1:39
    2014年10月3日 1:02
  • gekkaさん

    返信ありがとうございます。
    短時間にコードまで含めていただいて。

    ■1つめ

    単一のシートを選択した時でも「◯◯1.pdf」のように必ずナンバリングされてしまったので30行目の
    If (colSheets.Count > 0) Then を
    If (colSheets.Count > 1) Then としました。

    すると理想通りの挙動が出来ました。

    ■2つめ

    こちらも理想通りの挙動でした。

    ■全体

    私の環境では速度はどちらも大して変わらないようです。
    一度に処理する件数も多くて10件程度なのでこれくらいならどちらを選んでも変わらないかもしれません。
    マクロ自体の速度より、PC側の状況による影響の方が大きいかも。

    再度、既存の同名ファイルに上書きすべきか否かを検討して適した方を採用したいと思います。

    これで解決出来ました。本当にありがとうございます。


    • 編集済み junnny 2014年10月3日 2:59
    2014年10月3日 2:57