Excel VBA ファイル操作

Excel VBA のトップに戻る
Excel VBA 目次

索引

UNICODE でテキスト保存

 海外から、Excelで、毎月、売り上げのトランザクション・ファイルが送られてきます。
 これを、期末に、自動で集計するためのマクロを作りました。
 テキスト保存する形式を、ShiftJIS、Unicode(UTF16)、UTF-8 から選択できるところが売りです。


ShiftJISUnicode(UTF16)UTF-8
Excelシートをテキスト保存SaveAs メソッドSaveAs メソッドUTF-8ファイル作成 for VBA
テキストを読み込みテキストストリームオブジェクトADODBストリームADODBストリーム
テキストに書き出しテキストストリームオブジェクトテキストストリームオブジェクトUTF-8ファイル作成 for VBA

 Excelのマクロでテキスト出力すると、デフォルトロケール(通常は1041で Shift_JIS)になります。
 籠谷裕人さん作成の、下記のクラスモジュールを使うと、UTF-8、UTF-16で出力できるようになります。

「UTF-8ファイル作成 for VBA (utf8vba.zip)」
http://www.vector.co.jp/soft/winnt/prog/se320375.html
 ダウンロードすると、Sample.bas が入っていますので、これを参考に改変します。

このマクロをダウンロードできます。SaveAsUnicodeTextVBA2.xls
中国語のサンプルもダウンロードできます。Chinese.xls

1.マクロの機能
 (1).このExcelシートと同じフォルダの全てのExcelシートを、テキスト保存します。
 (2).保存するテキストの形式を、ShiftJIS、Unicode(UTF16)、Unicode(UTF8)から選択できます。
 (3).保存したテキストを一つのファイルに集約できます。
 (4).集約(合体)したファイルは、ソートして出力します。

2.マクロの使い方
 (1).作業用のフォルダを作ります。
 (2).テキスト保存したいExcelブック(1つでも複数でも可)を、作業用フォルダに登録します。
 (3).このマクロ Excelも、作業用のフォルダに保存します。
 (4).作業用のフォルダから、このマクロ Excelを開いて、テキスト形式のボタンを押します。
 (5).テキスト保存したファイルは、最後に1つのファイルに合体します。合体ファイルは、作業用フォルダ名をファイル名として、作成します。

Option Explicit
Option Base 1

Dim テキスト形式 As String
Dim 入力ファイル名 As String
Dim 出力ファイル名 As String
Dim 入力行 As String
Dim 出力行 As String
Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
Dim 入力テキストストリームオブジェクト As Object    ' TextStream
Dim 出力テキストストリームオブジェクト As Object    ' TextStream
'参照設定:Microsoft ActiveX Data Objects x.x Library
Dim ADODBストリーム As ADODB.Stream                 ' ADODB.Stream
Dim テキスト As String
Dim 現在のパス As String
Dim フォルダ As Object
'Dim サブフォルダ As Object
Dim ファイル As Object
Dim フォルダパス As String
'Dim ファイル内容 As Variant
Dim 開始日時 As Variant
Dim 終了日時 As Variant
Dim 処理行カウンタ As Long
Dim ヘッダ行数 As Integer
Dim ファイル内カウンタ As Long
Dim データ配列() As Variant
Dim データ行数 As Long
Dim 処理行 As Long
Dim 処理内容 As String
Dim 列数 As Integer
Dim 列 As Integer
'UTF-8で出力用
Dim f1 As New TextFile


'メインフロー ★ここから★*************************************
Sub ShiftJISで保存()
   
    開始日時 = Now                ' 開始時刻を変数に格納します。
 
   テキスト形式 = "ShiftJIS"
   Call Excelを開く(テキスト形式)
   Call ShiftJISテキスト合体

   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

Sub UTF16で保存()
    開始日時 = Now                ' 開始時刻を変数に格納します。
 
   テキスト形式 = "UTF16"
   Call Excelを開く(テキスト形式)
   Call UTF16テキスト合体
   
   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

Sub UTF8で保存()
    
    開始日時 = Now                ' 開始時刻を変数に格納します。
 
   テキスト形式 = "UTF8"
   Call Excelを開く(テキスト形式)
   Call UTF8テキスト合体
   
   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub
'メインフロー ☆ここまで☆*************************************

'**************************************************************
Private Sub Excelを開く(保存形式 As String)

   ThisWorkbook.Activate
    If Range("B20").Value = True Then
      ヘッダ行数 = Range("C21").Value
    Else
      ヘッダ行数 = 0
    End If
    
   現在のパス = ActiveWorkbook.path

   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス)
   
   データ行数 = 0
   
   '★Excelの存在するフォルダの、全てのファイルを対象に検索
    For Each ファイル In フォルダ.Files

      入力ファイル名 = ファイル.path
      
      '拡張子 xls で、マクロ自分自身以外のみを対象
      If Right(入力ファイル名, 3) = "xls" _
      And Mid(入力ファイル名, InStrRev(入力ファイル名, "\") + 1, 20) _
      <> "SaveAsUnicodeTextVBA" Then
         
          ' 指定ファイルをOPEN
          Workbooks.Open Filename:=入力ファイル名
          
          データ行数 = データ行数 + Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

          Select Case 保存形式
            Case "ShiftJIS"
               出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 4) & "ShiftJIS.txt"
               Call ShiftJISで出力
            Case "UTF16"
               出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 4) & "UTF16.txt"
               Call UTF16で出力
            Case "UTF8"
               出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 4) & "UTF8.txt"
               Call UTF8で出力
            Case Else
               Stop
               MsgBox "保存形式を判断できません。"
               Exit Sub
          End Select
          
         ' 開いたExcelをCLOSE
         ActiveWorkbook.Close savechanges:=False
      End If
      
    Next '★ファイル
    
   Set フォルダ = Nothing
   Set ファイルシステムオブジェクト = Nothing

End Sub
'**************************************************************


'Excel からテキスト出力 ★ここから★******************************

Private Sub ShiftJISで出力()
    ActiveWorkbook.SaveAs _
      Filename:=出力ファイル名, _
      FileFormat:=xlText, CreateBackup:=False
End Sub

Private Sub UTF16で出力()
    ActiveWorkbook.SaveAs _
      Filename:=出力ファイル名, _
      FileFormat:=xlUnicodeText, CreateBackup:=False
End Sub

Private Sub UTF8で出力()
   f1.FileCreate 出力ファイル名, "UTF-8"
   For 処理行 = 1 To Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
      列数 = Cells(処理行, ActiveSheet.Columns.Count).End(xlToLeft).Column
      If 列数 > 1 Then
         For 列 = 1 To 列数 - 1
            f1.TextWrite Range("A1").Cells(処理行, 列).Value & vbTab
         Next 列
      End If
      f1.TextWrite Range("A1").Cells(処理行, 列).Value
      f1.TextWrite vbCrLf
   Next 処理行
    f1.FileClose
End Sub
'Excel からテキスト出力 ☆ここまで☆******************************


'複数のテキスト・ファイルを、一つに合体 ★ここから★**************

Private Sub ShiftJISテキスト合体()

   ReDim データ配列(データ行数)

   現在のパス = ActiveWorkbook.path
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス)
   
   ' 出力ファイル名を作成
   出力ファイル名 = 現在のパス & "\" & Right(現在のパス, Len(現在のパス) - InStrRev(現在のパス, "\")) & "ShiftJIS.txt"

   処理行カウンタ = 0
   処理内容 = "☆テキストファイル読み込み☆ "
   '★Excelの存在するフォルダの、全てのファイルを対象に検索
    For Each ファイル In フォルダ.Files
      
      入力ファイル名 = ファイル.path

      'ファイル名ShiftJIS、拡張子 txt のみを対象。合体ファイル、自分自身以外のみを対象
      If Right(入力ファイル名, 12) = "ShiftJIS.txt" _
         And 入力ファイル名 <> 出力ファイル名 Then

          ' 指定ファイルをOPEN(入力モード)
          Set 入力テキストストリームオブジェクト = _
          ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1)
      
         ファイル内カウンタ = 0
         '*************データを一行ずつ読んで、書き込む***********
         Do Until 入力テキストストリームオブジェクト.AtEndOfStream
  
            ファイル内カウンタ = ファイル内カウンタ + 1
           
           ' レコードの読み込み
           入力行 = 入力テキストストリームオブジェクト.ReadLine

            テキスト = Replace(入力行, vbTab, "")

            If Trim(テキスト) <> "" And ファイル内カウンタ > ヘッダ行数 Then
               処理行カウンタ = 処理行カウンタ + 1
               データ配列(処理行カウンタ) = 入力行
            End If
   
           If (処理行カウンタ Mod 1000) = 0 Then
               Application.StatusBar = 処理内容 & 処理行カウンタ & " 行目を読込み"
           End If
           
           ' 最終行まで繰り返す
         Loop
      
         ' 指定ファイルをCLOSE
         入力テキストストリームオブジェクト.Close
         Set 入力テキストストリームオブジェクト = Nothing

      End If

    Next '★ファイル
   
   処理内容 = "★ 出力データを並び替え ★"
   Application.StatusBar = 処理内容
   Call クイックソート(データ配列, 1, 処理行カウンタ)
    
    
   処理内容 = "☆ 合体ファイルとして書き出し ☆ "
   Application.StatusBar = 処理内容

   '出力ファイルをオープン(出力モード)
   Set 出力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.CreateTextFile(出力ファイル名)
   
   For 処理行 = 1 To 処理行カウンタ
      出力テキストストリームオブジェクト.WriteLine データ配列(処理行)         ' 改行(CrLf)付き
   Next 処理行
    
   出力テキストストリームオブジェクト.Close
   Set 出力テキストストリームオブジェクト = Nothing
    
   Set ファイルシステムオブジェクト = Nothing
   
End Sub


Private Sub UTF16テキスト合体()

   ReDim データ配列(データ行数)

   現在のパス = ActiveWorkbook.path
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス)
   
   ' 出力ファイル名を作成
   出力ファイル名 = 現在のパス & "\" & Right(現在のパス, Len(現在のパス) - InStrRev(現在のパス, "\")) & "UTF16.txt"

   処理行カウンタ = 0
   処理内容 = "☆テキストファイル読み込み☆ "
   '★Excelの存在するフォルダの、全てのファイルを対象に検索
    For Each ファイル In フォルダ.Files

      入力ファイル名 = ファイル.path
      
      'ファイル名UTF16、拡張子 txt のみを対象。合体ファイル、自分自身以外のみを対象
      If Right(入力ファイル名, 9) = "UTF16.txt" _
         And 入力ファイル名 <> 出力ファイル名 Then

         ' 指定ファイルをOPEN(入力モード)
         'ADODB.Stream生成
         Set ADODBストリーム = New ADODB.Stream
         
         With ADODBストリーム
            .Type = adTypeText 'Textモード
            .Charset = "Unicode" '文字コード(Shift_JIS, UTF-8など)
            .Open              'Streamのオープン
            .LoadFromFile (入力ファイル名)
         End With
         
         ファイル内カウンタ = 0
         '*************データを一行ずつ読んで、書き込む***********
         Do Until ADODBストリーム.EOS
  
            ファイル内カウンタ = ファイル内カウンタ + 1
           
           ' レコードの読み込み
           入力行 = ADODBストリーム.ReadText(adReadLine)

            テキスト = Replace(入力行, vbTab, "")
            
            If Trim(テキスト) <> "" And ファイル内カウンタ > ヘッダ行数 Then
               処理行カウンタ = 処理行カウンタ + 1
               データ配列(処理行カウンタ) = 入力行
            End If
   
           If (処理行カウンタ Mod 1000) = 0 Then
            Application.StatusBar = 処理内容 & 処理行カウンタ & " 行目を読込み"
           End If
           
           ' 最終行まで繰り返す
         Loop
      
         ' 指定ファイルをCLOSE
         ADODBストリーム.Close
         Set ADODBストリーム = Nothing
      End If

    Next '★ファイル
   
   処理内容 = "★ 出力データを並び替え ★"
   Application.StatusBar = 処理内容
   Call クイックソート(データ配列, 1, 処理行カウンタ)
    
    
   処理内容 = "☆ 合体ファイルとして書き出し ☆ "
   Application.StatusBar = 処理内容
   '出力ファイルをオープン(出力モード)
   Set 出力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.CreateTextFile(出力ファイル名, False, True)
   
   For 処理行 = 1 To 処理行カウンタ
      出力テキストストリームオブジェクト.WriteLine データ配列(処理行)         ' 改行(CrLf)付き
   Next 処理行
    
   出力テキストストリームオブジェクト.Close
   Set 出力テキストストリームオブジェクト = Nothing
    
   Set ファイルシステムオブジェクト = Nothing
   
End Sub


Private Sub UTF8テキスト合体()

   ReDim データ配列(データ行数)

   現在のパス = ActiveWorkbook.path
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス)
   
   ' 出力ファイル名を作成
   出力ファイル名 = 現在のパス & "\" & Right(現在のパス, Len(現在のパス) - InStrRev(現在のパス, "\")) & "UTF8.txt"

   処理行カウンタ = 0
   処理内容 = "☆テキストファイル読み込み☆ "
   '★Excelの存在するフォルダの、全てのファイルを対象に検索
    For Each ファイル In フォルダ.Files

      入力ファイル名 = ファイル.path
      
      'ファイル名UTF8、拡張子 txt のみを対象。合体ファイル、自分自身以外のみを対象
      If Right(入力ファイル名, 8) = "UTF8.txt" _
         And 入力ファイル名 <> 出力ファイル名 Then

         ' 指定ファイルをOPEN(入力モード)
         'ADODB.Stream生成
         Set ADODBストリーム = New ADODB.Stream
         
         With ADODBストリーム
            .Type = adTypeText 'Textモード
            .Charset = "UTF-8" '文字コード(Shift_JIS, Unicodeなど)
            .Open              'Streamのオープン
            .LoadFromFile (入力ファイル名)
         End With
         
         ファイル内カウンタ = 0
         '*************データを一行ずつ読んで、書き込む***********
         Do Until ADODBストリーム.EOS
  
            ファイル内カウンタ = ファイル内カウンタ + 1
           
           ' レコードの読み込み
           入力行 = ADODBストリーム.ReadText(adReadLine)
            テキスト = Replace(入力行, vbTab, "")
            
            If Trim(テキスト) <> "" And ファイル内カウンタ > ヘッダ行数 Then
               処理行カウンタ = 処理行カウンタ + 1
               データ配列(処理行カウンタ) = 入力行
            End If
   
           If (処理行カウンタ Mod 1000) = 0 Then
            Application.StatusBar = 処理内容 & 処理行カウンタ & " 行目を読込み"
           End If
           
           ' 最終行まで繰り返す
         Loop
      
         ' 指定ファイルをCLOSE
         ADODBストリーム.Close
         Set ADODBストリーム = Nothing
      End If

    Next '★ファイル
   
   処理内容 = "★ 出力データを並び替え ★"
   Application.StatusBar = 処理内容
   Call クイックソート(データ配列, 1, 処理行カウンタ)
    
    
   処理内容 = "☆ 合体ファイルとして書き出し ☆ "
   Application.StatusBar = 処理内容
   '出力ファイルをオープン(出力モード)
   f1.FileCreate 出力ファイル名, "UTF-8"
   
   For 処理行 = 1 To 処理行カウンタ
      f1.TextWrite データ配列(処理行)
      f1.TextWrite vbCrLf
   Next 処理行
    
    f1.FileClose
    
   Set ファイルシステムオブジェクト = Nothing
   
End Sub
'複数のテキスト・ファイルを、一つに合体 ☆ここまで☆**************

 解説:

 SaveAs メソッドを、Workbook オブジェクトに指定した場合、ブックの内容を、別のファイルに保存します。

 expression.SaveAs(FileName, FileFormat, Password, WriteResPassword, ReadOnlyRecommended, CreateBackup, AccessMode, ConflictResolution, AddToMru, TextCodepage, TextVisualLayout, Local)

 expression   必ず指定します。この場合は、Workbook オブジェクトを返すオブジェクト式を指定します。

 Filename   省略可能です。バリアント型 (Variant) の値を使用します。保存するファイルの名前を表す文字列を指定します。絶対パスを含めることもできます。絶対パスを含めない場合は、ファイルはカレント フォルダに保存されます。

 FileFormat   省略可能です。バリアント型 (Variant) の値を使用します。ファイルを保存するときのファイル形式を指定します。
指定できる形式は、FileFormat プロパティのいずれかを指定します。既存のファイルでは、指定された最後のファイル形式が既定のファイル形式です。新しいファイルでは、現在使用されている Excel のバージョンでのファイル形式が既定のファイル形式です。

 Password   省略可能です。バリアント型 (Variant) の値を使用します。保存するファイルに設定する読み取りパスワードを表す文字列を指定します。パスワードは 15 文字以内の文字列で指定し、大文字と小文字が区別されます。

 WriteResPassword   省略可能です。バリアント型 (Variant) の値を使用します。保存するファイルに設定する書き込みパスワードを表す文字列を指定します。パスワードを設定して保存したファイルを、パスワードを指定しないで開くと、ファイルは読み取り専用で開かれます。

 ReadOnlyRecommended   省略可能です。バリアント型 (Variant) の値を使用します。ファイルを開くときに、読み取り専用で開くことを推奨するメッセージを表示するには、True を指定します。

 CreateBackup   省略可能です。バリアント型 (Variant) の値を使用します。バックアップ ファイルを作成するには、True を指定します。

 AccessMode   省略可能です。XlSaveAsAccessMode クラスの定数を使用します。
使用できる定数は、次に示す XlSaveAsAccessMode クラスのいずれかです。
xlExclusive  排他モード
xlNoChange (既定値)  アクセス モードを変更しない
xlShared  共有モード  この引数を省略すると、アクセス モードは変更されません。共有ファイルをファイル名を変えずに保存した場合は、この引数は無視されます。アクセス モードを変更するには、ExclusiveAccess メソッドを使います。

 ConflictResolution   省略可能です。XlSaveConflictResolution クラスの定数を使用します。
使用できる定数は、次に示す XlSaveConflictResolution クラスのいずれかです。
xlUserResolution  [変更箇所のコンフリクト] ダイアログ ボックスを表示
xlLocalSessionChanges  自動的にローカル ユーザーの変更を反映
xlOtherSessionChanges  他のユーザーの変更を反映   この引数を省略すると、[変更箇所のコンフリクト] ダイアログ ボックスが表示されます。

 AddToMru   省略可能です。バリアント型 (Variant) の値を使用します。最近使用したファイルの一覧にブックを追加するには True を指定します。既定値は False です。

 TextCodePage   省略可能です。バリアント型 (Variant) の値を使用します。英語の Excel では使用できません。

 TextVisualLayout   省略可能です。バリアント型 (Variant) の値を使用します。英語の Excel では使用できません。

 Local  省略可能です。バリアント型 (Variant) の値を使用します。Excel の言語設定 (コントロール パネルの設定を含む) に合わせてファイルを保存するには、True を指定します。Visual Basic for Applications (VBA) の言語設定に合わせてファイルを保存するには、False (既定値) を指定します。通常この設定は、Workbooks.Open を実行する VBA プロジェクトが Excel バージョン 5 または 95 の各国語版で作成されたプロジェクトでない限り、英語 (U.S.) になります。

 次の例は、新しいブックを作成し、ユーザーにファイル名を入力させるダイアログ ボックスを表示して、そのファイル名でブックを保存します。

Set NewBook = Workbooks.Add
Do
    fName = Application.GetSaveAsFilename
Loop Until fName <> False
NewBook.SaveAs Filename:=fName

 ADODB.Stream オブジェクトのコレクションおよびプロパティを使うと、次の操作を行うことができます。
 ADODB.Stream を使うためには Microsoft ActiveX Data Objectを参照設定します。

ADO レコードセット、レコード、およびストリーム オブジェクトを使用してドキュメントを開く方法
http://support.microsoft.com/kb/248255/ja

http://msdn.microsoft.com/ja-jp/library/cc364272.aspx

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


ホームページのトップに戻る