(Excel) 一括処理

あるフォルダ内のファイルを一括処理

前提条件

• 1つのフォルダ
• 拡張子が同一のファイル全て
• 呼び出したワークブックにシートとして移動

マクロ

c:\Data内の.csvファイルを一括処理。csv以外の場合は個別処理のFormat:=を変える

1. タブ区切り
2. カンマ区切り
3. スペース区切り
4. セミコロン区切り
5. 区切り文字なし(?)
6. Delimiter:=で定義

関数

Sub 一括処理()
  Dim BaseName As String
  BaseName = ActiveWorkbook.Name
  With Application.FileSearch
      .LookIn = "c:\Data"
      .Filename = "*.csv"
      .Execute
      'MsgBox .FoundFiles.Count & "個発見"
      If .FoundFiles.Count = 0 Then
          MsgBox .LookIn & "にファイルがありません"
          Exit Sub
      End If
      For i = 1 To .FoundFiles.Count
          'Cells(i, 1) = .FoundFiles(i)
          個別処理 bname:=BaseName, fname:=.FoundFiles(i)
      Next i
  End With
End Sub

Sub 個別処理(bname As String, fname As String)
  'MsgBox fname
  Workbooks.Open Filename:=fname, Format:=2
  ActiveWorkbook.Worksheets(1).Move after:=Workbooks(bname).Worksheets(Workbooks(bname).Sheets.Count)
  '処理内容 ここから
  
  '処理内容 ここまで
  Workbooks(bname).Activate
End Sub

Excelに埋込まれたJPEG画像を抜き出す

画像が保存できない

どうもVBAにPictureオブジェクトを保存する術が無いらしく、頑張ってもクリップボードにコピーしてお手上げ。 htmlに書き出すと*.filesフォルダに保存されるのを利用する。

保存されるJPEG画像

ファイル名はimage???.jpgになってしまうが、EXIF情報はそのまま保持され、サイズもオリジナルのままらしい。

マクロ

動作

c:\Dataに置いた.xlsファイルのjpgを抜き出す。 生成される.htmファイルや.filesフォルダの.jpg)以外のファイルは削除する。

ソース

内部ではkillを使ってファイルを消しているため、ファイル名の指定を失敗するとシステムごと即死させる危険性がある。 Collectionを使ったのはFileSearchの情報が関数単位で保持されないため。

個別処理()の中でFileSearchを使う今回の場合、ベースの関数に戻ってきた時にFoundFilesの中身が個別処理()で行なった結果にすり代わってしまう。 変数名は試行錯誤しながら泥縄的に付けたので分かりづらい。

'xlsファイル->HTML化->画像だけ選んで他を消す
Sub xlsから画像抽出()
  Dim baseName As String
  Dim i As Integer
  baseName = ActiveWorkbook.Name
  Dim xlsList As New Collection
  With Application.FileSearch
      .LookIn = "c:\Data"
      .Filename = "*.xls"
      .Execute
      If .FoundFiles.Count = 0 Then
          MsgBox .LookIn & "にファイルがありません"
          Exit Sub
      End If
      For i = 1 To .FoundFiles.Count
          Call xlsList.Add(.FoundFiles(i))
      Next i
      For i = 1 To xlsList.Count
          'Cells(i, 1) = .FoundFiles(i)
          個別処理 rootName:=baseName, fname:=xlsList(i), counts:=i
      Next i
  End With
End Sub

Sub 個別処理(rootName As String, fname As String, counts As Integer)
  'MsgBox fname
  Dim nSheets As Integer
  Dim nBooks As Integer
  Workbooks.Open UpdateLinks:=False, Filename:=fname, Format:=2
  nBooks = Workbooks.Count
  Workbooks(nBooks).Activate
  bName = ActiveWorkbook.Name
  bNameLen = Len(bName)
  FolderName = Left(bName, bNameLen - 3) & "files"
  saveName = "c:\Data\" & Left(bName, bNameLen - 3) & "htm"
  ActiveWorkbook.SaveAs Filename:=saveName, FileFormat:=xlHtml
  ActiveWorkbook.Close
  '処理内容 ここまで
  Workbooks(rootName).Activate
  With Application.FileSearch
      .LookIn = "c:\Data\" & FolderName
      .Filename = "*.htm;*.png);*.xml;*.css"
      .Execute
      For i = 1 To .FoundFiles.Count
          Kill .FoundFiles(i)
      Next i
  End With
  Kill saveName
End Sub

ちなみに

emzファイル

ファイル名をemz->emf.gzとして解凍ソフトで開くとemfファイルになる。が、Excelにメタファイルで貼ってしまった時点で情報は失なわれている可能性が高いため再利用が困難。

msoファイル

IEとの組合せで開けるようだが不要。無駄にデカい。