[[20170825013610]]　『ファイル名に同じ文字列があれば、ファイルを結合』（初心者）　ページの最後に飛ぶ

『ファイル名に同じ文字列があれば、ファイルを結合したい』（初心者）

ID1234_1.pdf
ID1234_2.pdf
ID1234_3.pdf
ID1234_4.pdf
ID1234_5.pdf
ID1234_6.pdf
ID1234_7.pdf
ID1234_8.pdf
ID1234_9.pdf
ID1234_10.pdf
ID0000_1.pdf
ID0000_2.pdf
ID0000_3.pdf
ID0000_4.pdf
ID0000_5.pdf
ID9876_1.pdf

上記のようなファイル名のPDFが同じフォルダ内にはいっており、同じIDであれば12345といった後ろ側の番号順でPDFファイルを1つのファイルに結合し、ID番号のみで新しいPDFファイルを作成したいです。ID番号は毎月かわります。
例：
ID0000_1.pdf
ID0000_2.pdf
ID0000_3.pdf　　→　　ID0000.pdf
ID0000_4.pdf
ID0000_5.pdf

以下が途中のソースコードです。
ここからどのように書けばよいのかおおしえください。。
acrobatを使用するようにしていますが、違う方法でもかまいません。

Public Sub Sample()

  Dim v As Variant '結合元PDFファイル

  v = Array( _
        "C:\Users\Username\Desktop\PDF\ID0000_1.pdf", _
        "C:\Users\Username\Desktop\PDF\ID0000_2.pdf", _
        "C:\Users\Username\Desktop\PDF\ID0000_3.pdf" _
        "C:\Users\Username\Desktop\PDF\ID0000_4.pdf" _
        "C:\Users\Username\Desktop\PDF\ID0000_5.pdf" _

      )
  MergePDF v, "C:\Users\Username\Desktop\PDF\\ID0000.pdf"
End Sub

Private Sub MergePDF(ByVal InputFilePath As Variant, _

                     ByVal OutputFilePath As String)
'Acrobatを利用してPDFファイルを結合する
  Dim pdoc As Object
  Dim i As Long
  Const PDSaveFull = &H1
  set

  With CreateObject("AcroExch.PDDoc")
    If .Create = True Then
      Set pdoc = CreateObject("AcroExch.PDDoc")
      For i = LBound(InputFilePath) To UBound(InputFilePath)
        If pdoc.Open(InputFilePath(i)) = True Then
          .InsertPages .GetNumPages() - 1, pdoc, 0, pdoc.GetNumPages() - 1, True
          pdoc.Close
        End If
      Next
      .Save PDSaveFull, OutputFilePath
      .Close
    End If
  End With
End Sub

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

初心者備忘録さんのところのコードですかね？自分で考えたものではないコードを書くときは、出典元を明らかにすべきですよ。それが作者に対する敬意であり、著作権を尊重した行為ってもんです。

で、ファイル名の問題点があるので、ロジックが難しくなるのですが、ファイル名の命名規則は変えられませんか？つまり、ファイル名は文字列なので、以下を単純にソートすると…。

ID0000_1.pdf
ID0000_2.pdf
ID0000_10.pdf
　↓
ID0000_1.pdf
ID0000_10.pdf
ID0000_2.pdf

こうなってしまうのですよ。だから、番号部分だけ抜き出して、本来のファイル名とは別に考えないといけない。
しかし、ID0000_0001.pdf のように、十分な桁数の前ゼロが付いていれば、文字列のソートで済むので、簡単なのです。いかがですか？
（???） 2017/08/25(金) 09:20

不明点を追加確認します。
・後ろの数字は、抜け番がありますか？　1の次は2とは限らず、4等のように飛ぶ場合があるかどうか。
・最大の数字は幾つくらいですか？
（???） 2017/08/25(金) 09:30

（???）様

おそくなり申し訳ありません。コメントくださり有難うございます。

なるほど、色々さがしていたのでどなたものか現状不明です。。ブログなどでソースをのせてくださっているかたには本当に頭が上がらない限りです。感謝しております。
ご教授くださり大変感謝いたします。勉強になります！

ID0000の部分が変わらなければ、ID0000_0001.pdfのようにファイル名のルールを変更することは可能です。
1の次は4などは現在ございません。
また、ファイル自体は500個程度ありますが、まとめるファイルは1つあたり最大15ファイルです。
（初心者） 2017/08/26(土) 00:00

末尾の数字は前ゼロを付けて桁を揃えている、という前提であれば、以下。
ファイル名が目的のものか確認できた後は、MsgBoxを使っている2箇所を、PDF連結のプロシジャ呼び出しに変えれば良いでしょう。
（Joinは表示用に整形しただけなので、不要）

 Sub test()
    Dim AR As Object
    Dim cPath As String
    Dim cFile As String
    Dim iw As Long
    Dim cw1 As String
    Dim cw2 As String

    Set AR = CreateObject("System.Collections.ArrayList")
    cPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\pdf\"

    cFile = Dir(cPath & "*_*.pdf")
    While cFile <> ""
        iw = InStrRev(cFile, "_")
        If 0 < iw Then
            cw2 = Left(cFile, iw - 1)
            If cw1 <> cw2 Then
                If cw1 <> "" Then
                    AR.Sort
                    MsgBox Join(AR.toarray, vbLf), , cw1 & ".pdf"
                    AR.Clear
                End If
                cw1 = cw2
            End If
            AR.Add cPath & cFile
        End If
        cFile = Dir
    Wend

    MsgBox Join(AR.toarray, vbLf), , cw1 & ".pdf"
    Set AR = Nothing
 End Sub
（???） 2017/08/28(月) 09:07

このコードだと、最初は問題ないですが、長く使っていくと問題があると気づきました。
Dir関数は、ファイルのエントリ順に返すだけであり、名前順に返るとは限りません。なので、15個の仲間があったとして、途中で違うファイルが割り込むと、2つに分かれてしまいます。

対応するには、フォルダ内のファイルを全選択して、別フォルダに移動またはコピーすることで強制的に名前順に並べておくか、またはコードを変更して、もうひとつArrayListオブジェクトを用意し、全ファイル読み込んでからSortし、そこからファイルを取り出していくようにしてください。
（???） 2017/08/28(月) 09:28

（???）様
私もすぐにぱっと思い浮かぶようなりたいです。

ファイルはご指導いただいた通り、所定のフォルダで強制的に名前をいったん並べて実行してみました。
型をかえてはいないのですが、以下の部分で「実行時エラー13 型が一致しません」とエラーとなります。。。

     For i = LBound(InputFilePath) To UBound(InputFilePath)
cpathやcFile,iw,iなどの型をStringやVariantなどに変更しても同じエラーとなってしまいます。
ファイル名は全て、「ID1234_0001.pdf」のように修正済となります。

どこの型を揃える必要があるのでしょうか？？

実行したのは以下のものです。

Sub test()

    Dim AR As Object
    Dim cPath As String
    Dim cFile As String
    Dim iw As Long
    Dim cw1 As String
    Dim cw2 As String
    Set AR = CreateObject("System.Collections.ArrayList")
    cPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\pdf\"
    cFile = Dir(cPath & "*_*.pdf")
    While cFile <> ""
        iw = InStrRev(cFile, "_")
        If 0 < iw Then
            cw2 = Left(cFile, iw - 1)
            If cw1 <> cw2 Then
                If cw1 <> "" Then
                    AR.Sort
                     Call MergePDF(ByVal InputFilePath, ByVal OutputFilePath)
                    'MsgBox Join(AR.toarray, vbLf), , cw1 & ".pdf"
                    AR.Clear
                End If
                cw1 = cw2
            End If
            AR.Add cPath & cFile
        End If
        cFile = Dir
    Wend
   Call MergePDF(ByVal InputFilePath, ByVal OutputFilePath)
　'MsgBox Join(AR.toarray, vbLf), , cw1 & ".pdf"
    Set AR = Nothing
 End Sub

Private Sub MergePDF(ByVal InputFilePath As Variant, _

                     ByVal OutputFilePath As String)
'Acrobatを利用してPDFファイルを結合する
  Dim pdoc As Object
  Dim i As Long
  Const PDSaveFull = &H1

  With CreateObject("AcroExch.PDDoc")
    If .Create = True Then
      Set pdoc = CreateObject("AcroExch.PDDoc")
      For i = LBound(InputFilePath) To UBound(InputFilePath)
        If pdoc.Open(InputFilePath(i)) = True Then
          .InsertPages .GetNumPages() - 1, pdoc, 0, pdoc.GetNumPages() - 1, True
          pdoc.Close
        End If
      Next
      .Save PDSaveFull, OutputFilePath
      .Close
    End If
  End With
End Sub

（初心者） 2017/08/29(火) 01:13

 ＞                    Call MergePDF(ByVal InputFilePath, ByVal OutputFilePath)
これは、呼ばれる側の書き方です。呼び側だと、以下のような感じ。
    Call MergePDF(AR.toarray, cw1 & ".pdf")

これが書けないようならば、外部オブジェクトを扱うコードなんて、まだ貴方には無理、と思いますよ？背伸びしすぎていると思います。
（???） 2017/08/29(火) 09:12

（???）さま
おっしゃる通りはじめてな部分があり戸惑いましたが、細々したところを修正し何とかできました！
（???）さまに教えていただいたコード大変勉強になりました。ありがとうございます。しっかり飲み込めるよう反復いたします。ほんとうにありがとうございます。
（初心者） 2017/08/30(水) 21:53

できあがったようですので、こう来ないかな？

ArrayListをもう1つ加えて、一旦ソートしてから処理することで、ファイルの並び順がバラバラでも、新しいフォルダへの移動が不要なように変更した版を書いておきます。

 Sub test()
    Dim AR1 As Object
    Dim AR2 As Object
    Dim cPath As String
    Dim cFile As String
    Dim cw1 As String
    Dim cw2 As String
    Dim i As Long
    Dim iw As Long

    Set AR1 = CreateObject("System.Collections.ArrayList")
    Set AR2 = CreateObject("System.Collections.ArrayList")
    cPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\pdf\"

    cFile = Dir(cPath & "*_*.pdf")
    While cFile <> ""
        AR1.Add cPath & cFile
        cFile = Dir
    Wend
    AR1.Sort

    For i = 0 To AR1.Count - 1
        iw = InStrRev(AR1(i), "_")
        If 0 < iw Then
            cw2 = Left(AR1(i), iw - 1)
            If cw1 <> cw2 Then
                If cw1 <> "" Then
                    AR2.Sort
                    MsgBox Join(AR2.toarray, vbLf), , cw1 & ".pdf"
                    AR2.Clear
                End If
                cw1 = cw2
            End If
            AR2.Add AR1(i)
        End If
    Next i

    MsgBox Join(AR2.toarray, vbLf), , cw1 & ".pdf"
    Set AR2 = Nothing
    Set AR1 = Nothing
 End Sub
（???） 2017/08/31(木) 16:30

コメント返信：

[ 一覧(最新更新順) ]

[[20170825013610]] 『ファイル名に同じ文字列があれば、ファイルを結合』（初心者） ページの最後に飛ぶ

[[20170825013610]]　『ファイル名に同じ文字列があれば、ファイルを結合』（初心者）　ページの最後に飛ぶ