summary.vbs

Option Explicit
'On Error Resume Next
' ----------------------------------------------------------------------
'   テキストファイルを入れたフォルダをドロップすると、
'   フォルダ内のファイルを一つのExcelブックに読み込みます
' ----------------------------------------------------------------------
if WScript.Arguments.Count = 0 then
  msgbox "フォルダをドロップして下さい"
  WScript.Quit 0
end if
 
'------------
' define
'------------
' *** 入力ファイルのフォーマット定義を有効にします ***
 Const adType=2:Const adCharset="euc-jp"   :Const adLineSeparator=10 'adLF
'Const adType=2:Const adCharset="shift-jis":Const adLineSeparator=-1 'adCRLF
 dim fso, xls, ado, arg, tmp
 
'------------
' initialize
'------------
WScript.echo "initializing..."
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set xls = WScript.CreateObject("Excel.Application")
Set ado = WScript.CreateObject("ADODB.Stream")
With ado
  .Type = adType
  .Charset = adCharset
  .LineSeparator = adLineSeparator
  .Open
End With
Set tmp = CreateTemplate()
 
'------------
' main
'------------
For Each arg In WScript.Arguments
  Call Folder2Book(arg)
Next
 
'------------
' finalize
'------------
tmp.Parent.Close
xls.Visible = True
Set xls = Nothing
Set ado = Nothing
Set fso = Nothing
 
' ----------------------------------------------------------------------
Sub Folder2Book(path)
  If not fso.FolderExists(path) Then
    Exit Sub
  End If
 
  With xls.WorkBooks.Add
    dim f
    For Each f In fso.GetFolder(path).Files
      WScript.echo f.Path
 
      'テンプレートシートを結果ブックの末尾へコピーする
      Call tmp.Copy(,.Sheets(.Sheets.Count))
 
      'ファイルを結果ブックの末尾のシートへ読み込む
      Call File2Sheet(f,.Sheets(.Sheets.Count))
    Next
 
    '結果ブックから、空のワークシートを削除する
    dim ws
    For Each ws In .Sheets
      If ws.UsedRange.Address = "$A$1" and ws.Range("$A$1").Value = "" Then
        ws.Delete
      End If
    Next
  End With
End Sub
 
' ----------------------------------------------------------------------
Function CreateTemplate()
  'テンプレートシートを作成し、オブジェクトへの参照を返す
  With xls.WorkBooks.Add
    Set CreateTemplate = .Sheets(1)
    With CreateTemplate
      .Name = "Template"
      .Cells.NumberFormatLocal = "@"
 
      With .Cells.Font
        .Size = 10
        .Name = "ＭＳ ゴシック"
      End With
 
      With .PageSetup
        .Orientation  = 2 '用紙の向き->縦(xlPortrait=1)横(xlLandscape=2)
        .LeftHeader   = "&A"
        .RightHeader  = "&D &T"
        .LeftFooter   = "&A"
        .CenterFooter = "&P / &N"
        .TopMargin    = 55 'マージンの単位はポイント
        .BottomMargin = 50 '1インチ = 72ポイント
        .FooterMargin = 25 '55ポイント = 72ポイント * 0.75インチ
      End With
    End With
 
    .Saved = True
  End With
End Function
 
' ----------------------------------------------------------------------
Sub File2Sheet(f,ws)
  'ファイルをarrに全件読み込み、最後に一回でシートに貼り付ける
  ado.LoadFromFile f.Path
  ado.Position = 0
 
  dim arr(65535,0)
  dim i
  i = 0
  Do While not ado.EOS and i < 65536
    arr(i,0) = ado.ReadText(-2) 'adReadAll=-1, adReadLine=-2
    i = i + 1
  Loop
 
  If i &gt; 0 Then
    ws.Range("A1:A" & i).Value = arr
  End If
 
  If Len(f.Name) &lt; 32 then
    ws.Name = f.Name
  Else
    msgbox f.Name & chr(13) & _
           "ファイル名が31文字を超えるため、シート名を付け替えませんでした" & chr(13) & _
           ">> " & ws.Name
  End If
End Sub