Excel VBA ファイル操作

テキストファイルの読み書き

英辞郎のテキスト・ファイルを、StarDict用 1行形式に変換する

　フリーの辞書ビュアとして、「StarDict」や「ColorDict」があります。
　私が、購入した英辞郎のテキスト・ファイルを、これらの辞書ビュアで読めるように変換するために作ったマクロを紹介します。

　このExcelをダウンロードできます。EigiroToOneLineVBA03.xls

　英辞郎のファイルは、一つの単語が、複数行のデータから成り立っている、特殊な形式のファイルです。

■inscription {名-1} : 記されたもの、題辞、碑文、銘■・I read the inscription on the gravestone. 私はその墓石に刻まれた文を読んだ。
■inscription {名-2} : 記すこと、記入
■inscription : 【レベル】8、【発音】inskri'p∫n、【＠】インスクリプション、【変化】《複》inscriptions、【分節】in・scrip・tion

　上の例では、最初に表示されるべき、発音記号を含む行が、最後になっています。
　このコンバータを使うと、辞書コンテンツとして、適切な順序に表示できるような、1行形式に変換されます。

　StarDict用 1行形式とは、見出しと本文が一行のテキスト・ファイルで、
１．見出し語と本文は、タブで区切られ、
２．本文中の改行が \n になっている、
３．改行は LF (UNIX形式)で、
４．文字コードが、UTF-8 のファイルです。

　参照：PDICテキスト形式の EJDIC テキスト・ファイルを、StarDict用 1行形式に変換する

Option Explicit

Dim 入力ファイル名 As String
Dim 出力ファイル名 As String
Dim 入力行 As String
Dim 出力行 As String
Dim 処理行カウンタ As Long
Dim 開始時刻 As Variant
Dim 終了時刻 As Variant


Sub 英辞郎→1行化()

   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim 入力テキストストリームオブジェクト As Object    ' TextStream
   Dim 出力テキストストリームオブジェクト As Object    ' TextStream
   Dim 旧StatusBar As String
   Dim 英単語 As String
   Dim 前英単語 As String
   Dim 訳語 As String
   Dim 訳語部分 As String
   Dim 最後の訳語 As String

   旧StatusBar = Application.DisplayStatusBar
   Application.DisplayStatusBar = True

   ChDrive ThisWorkbook.Path
   ChDir ThisWorkbook.Path

    '変換対象のファイル名とパス取得
    入力ファイル名 = Application.GetOpenFilename("TEXTファイル,*.txt")
    If 入力ファイル名 = "False" Then End
    出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 4) & "_1Line" & ".txt"

    開始時刻 = Now()

    '********************************
    'ファイルのオープン。
    処理行カウンタ = 0

    Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

    ' 指定ファイルをOPEN(入力モード)
    Set 入力テキストストリームオブジェクト = _
    ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1)

    ' 指定ファイルをOPEN(出力モード)
    Set 出力テキストストリームオブジェクト = _
    ファイルシステムオブジェクト.CreateTextFile(出力ファイル名)

    '*************データの読み込み***********
     Do Until 入力テキストストリームオブジェクト.AtEndOfStream
        処理行カウンタ = 処理行カウンタ + 1

        出力行 = ""
        ' レコードの読み込み
        入力行 = 入力テキストストリームオブジェクト.ReadLine

         If Asc(Mid(入力行, 2, 1)) > 64 And Asc(Mid(入力行, 2, 1)) < 123 Then
            If InStr(入力行, " ") > 0 Then
               If Mid(入力行, InStr(入力行, " ") + 1, 1) = " " _
               Or Mid(入力行, InStr(入力行, " ") + 1, 1) = ":" _
               Or Mid(入力行, InStr(入力行, " ") + 1, 1) = "{" Then
                  英単語 = Mid(入力行, 2, InStr(入力行, " ") - 2)

                  If 前英単語 <> 英単語 Then

                     If 最後の訳語 = "" Then
                        出力行 = 前英単語 & vbTab & 訳語
                     ElseIf 訳語 = "" Then
                        出力行 = 前英単語 & vbTab & 最後の訳語
                     Else
                        出力行 = 前英単語 & vbTab & 最後の訳語 & "\n" & 訳語
                     End If

                     If 前英単語 <> "" Then
                        出力テキストストリームオブジェクト.WriteLine 出力行         ' 改行(CrLf)付き
                     End If

                     前英単語 = 英単語
                     訳語 = ""
                     最後の訳語 = ""

                  End If

                  訳語部分 = LTrim(Right(入力行, Len(入力行) - Len(英単語) - 2))

                  If InStr(訳語部分, "\\") = 0 And InStr(訳語部分, "\") > 0 Then
                     'エスケープ文字を、明示する
                     訳語部分 = Replace(訳語部分, "\", "\\")
                  End If

                  If Left(訳語部分, 1) = ":" Then
                     最後の訳語 = LTrim(Right(訳語部分, Len(訳語部分) - 1))
                  Else
                     If 訳語 = "" Then
                        訳語 = 訳語部分
                     Else
                        訳語 = 訳語 & "\n" & 訳語部分
                     End If
                  End If

               End If
            End If
         End If

        If (処理行カウンタ Mod 10000) = 0 Then
         Application.StatusBar = 処理行カウンタ & " 行目を読込み"
        End If

        ' 最終行まで繰り返す
    Loop

   出力行 = 前英単語 & vbTab & 最後の訳語 & 訳語
   出力テキストストリームオブジェクト.WriteLine 出力行         ' 改行(CrLf)付き

    '**************終了処理*********************
    Application.StatusBar = 処理行カウンタ & " 最終行まで読込み完了"

    ' 指定ファイルをCLOSE
    入力テキストストリームオブジェクト.Close
    Set 入力テキストストリームオブジェクト = Nothing
    出力テキストストリームオブジェクト.Close
    Set 出力テキストストリームオブジェクト = Nothing

    Set ファイルシステムオブジェクト = Nothing

    終了時刻 = Now()
    MsgBox "処理が終了しました。" & Chr(13) & _
    "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly

    Application.StatusBar = False
   Application.DisplayStatusBar = 旧StatusBar

End Sub

　解説：
　StarDict には、StarDict Editor という辞書データをコンパイルするツールが付いています。
　StarDict 用の 1行テキスト形式にして StarDict Editor を使えば、どんな辞書データでも、StarDict で参照できるようになります。

　ところが、最初、下記のエラーが出て、コンパイルできませんでした。

Gtk-CRITICAL (recursed) **: gtk_text_buffer_emit_insert: assertion `g_utf8_validate (text, len, NULL)' failed
aborting...

　投入した、1行形式のテキスト・データに問題があると思って、Div を使って、テキスト・ファイルを 5分割して、やり直してみました。
　すると、4 つのファイルはコンパイルできて、1 つだけが同じエラーになりました。

　英辞郎のテキスト・ファイルは、約 25 万行あります。このため、
25 万行/5 → 5万行/5 → 1万行/5 → 2千行/5 → 400行/5 → 80行/5 → 16行
$コントロール文字\$ と、7回、同様な操作をして、問題部分を見つけました。
コントロール文字「\」が悪さをしていたのです。
　このため、上のマクロでは、\→\\ とエスケープして、エラーを回避しています。

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

PDICテキスト形式の EJDIC テキスト・ファイルを、StarDict用 1行形式に変換する

　逗子田越村新聞というサイトで、PrepTutor という名前で、フリーの英和辞書データをダウンロードできるように、公開していただいています。
　これは、EJDIC というフリーの英和辞書データの、誤字を訂正し、新語句を追加した、約46,700語収録の、英和辞書テキスト・データです。

　私が、このデータを使って、和英部分を補強して、PDICテキスト形式(見出語と訳語が１行毎に交互に並んだテキスト形式のファイル)に加工したものが、下記です。

PrepTutorEJDIC20131109.zip

　このテキスト・ファイルを、StarDict用 1行形式に変換するために作ったものが、下のマクロです。
　StarDict用 1行形式とは、見出し語と本文がタブで区切られ、本文の改行が \n になっている一行形式のテキストファイルです。

　このExcel マクロをダウンロードできます。PDICtoStarDictVBA00.xls

Option Explicit

Dim 入力ファイル名 As String
Dim 出力ファイル名 As String
Dim 入力行 As String
Dim 出力行 As String
Dim 処理行カウンタ As Long
Dim 開始時刻 As Variant
Dim 終了時刻 As Variant

Sub StarDict用変換()

Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
Dim 入力テキストストリームオブジェクト As Object    ' TextStream
Dim 出力テキストストリームオブジェクト As Object    ' TextStream

    '変換対象のファイル名とパスを指定
    入力ファイル名 = ThisWorkbook.Path & "\PrepTutorEJDIC渡辺和英付き空白追加20131109.txt"

    出力ファイル名 = ThisWorkbook.Path & "\EJDICforStarDict.txt"

    開始時刻 = Now()

    '********************************
    'ファイルのオープン。
    処理行カウンタ = 0

    Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

    ' 指定ファイルをOPEN(入力モード)
    Set 入力テキストストリームオブジェクト = _
    ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1)

    ' 指定ファイルをOPEN(出力モード)
    Set 出力テキストストリームオブジェクト = _
    ファイルシステムオブジェクト.CreateTextFile(出力ファイル名)

    出力行 = ""

    '*************データの読み込み***********
     Do Until 入力テキストストリームオブジェクト.AtEndOfStream
        処理行カウンタ = 処理行カウンタ + 1

        ' レコードの読み込み
        入力行 = 入力テキストストリームオブジェクト.ReadLine

        If 処理行カウンタ Mod 2 = 0 Then

         出力行 = 出力行 & vbTab & 入力行
         出力行 = Replace(出力行, "\", "\\")
         出力行 = Replace(出力行, " / ", "\n")

         出力テキストストリームオブジェクト.WriteLine 出力行         ' 改行(CrLf)付き
         出力行 = ""
        Else
         出力行 = 入力行
        End If

        ' 最終行まで繰り返す
    Loop

    ' 指定ファイルをCLOSE
    入力テキストストリームオブジェクト.Close
    Set 入力テキストストリームオブジェクト = Nothing
    出力テキストストリームオブジェクト.Close
    Set 出力テキストストリームオブジェクト = Nothing

    Set ファイルシステムオブジェクト = Nothing

    終了時刻 = Now()
    MsgBox "処理が終了しました。" & Chr(13) & _
    "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly

End Sub

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

Excel の指定した列データを、CSV または固定長でテキスト出力(汎用ツール)

　Excel の、特定列を指定して、CSV や固定長で、テキスト出力したいことが、時々あります。
　都度、指定項目にあわせてマクロを作るのは大変なので、汎用ツールを作ってみました。
　必要な抽出条件を登録して、名前を変えて保存しておけば、繰返し使うことができます。

　サンプル指定を登録してあります。
　このサンプルは、各、支店から、ばらばらな Excel 形式で送られてくる販売実績データを、サーバに登録するために、指定されたファイル・レイアウトの固定長テキストに出力するための設定例です。

　このExcelをダウンロードできます。CSVorFLT_generatorVBA01.xls

Option Explicit
Option Base 1

   Dim 最終行 As Long
   Dim 行 As Long
   Dim 対象シート As Worksheet
   Dim 対象シート名 As String
   Dim 開始行 As Long
   Dim 出力開始行 As Long

   Dim 対象ブック名 As String
   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim 出力テキストストリームオブジェクト As Object    ' TextStream
   Dim 現在のパス As String
   Dim 出力指定() As Variant
   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant
   Dim 出力ファイル名 As String
   Dim 出力行 As String
   Dim 除外シート名 As String
   Dim メッセージ As String
   Dim 正規表現オブジェクト As RegExp
   Dim メッセージ列 As String
   Dim シート追番 As Integer
   Dim 出力形式 As Integer
   Dim 出力項目数 As Integer
   Dim データ最終行摘出列 As String
   Dim 処理行 As Integer


Sub テキスト出力()

'   Set 正規表現オブジェクト = New RegExp
'   正規表現オブジェクト.Pattern = "[^\x01-\x7E]" '2バイト文字

   開始時刻 = Now()

   '変換対象のファイル名とパス取得
   現在のパス = ThisWorkbook.Path

   '処理対象の列を読み込む
   ThisWorkbook.Worksheets("スタート").Activate
   対象ブック名 = Range("C10").Value
   対象シート名 = Range("C11").Value
   除外シート名 = Range("D11").Value
   開始行 = Range("C12").Value
   メッセージ列 = Range("C13").Value

   出力ファイル名 = Range("G10").Value
   出力ファイル名 = 現在のパス & "\" & 出力ファイル名
   出力形式 = Range("F11").Value

   最終行 = Cells(ActiveSheet.Rows.Count, 4).End(xlUp).Row
   出力項目数 = 最終行 - 15

   出力指定 = Range("C16").Resize(出力項目数, 4).Value

   For 処理行 = 1 To 出力項目数
      If Len(Range("D16").Cells(処理行, 1).Value) < 3 Then
         データ最終行摘出列 = Range("D16").Cells(処理行, 1).Value
         Exit For
      End If
   Next 処理行

   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   '対象シートの指定有無で、処理を分ける

   If 対象シート名 <> "" Then

      Call データのマッピングとファイル出力

   Else

      Workbooks(対象ブック名).Activate

      ' 作業中のブックの、すべてのワークシートから指定列を検索します。
      シート追番 = 0
      For Each 対象シート In Worksheets
         対象シート.Activate
         対象シート名 = 対象シート.Name

         If 対象シート名 <> 除外シート名 Then
           シート追番 = シート追番 + 1
            Call データのマッピングとファイル出力

         End If
   'Stop
      Next '全てのシートを対象

   End If

   Set ファイルシステムオブジェクト = Nothing

'   Set 正規表現オブジェクト = Nothing

   ThisWorkbook.Worksheets("スタート").Activate
   Range("A1").Activate

   終了時刻 = Now()

   If メッセージ = "" Then
      MsgBox "処理が終了しました。" & Chr(13) _
      & "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。" & Chr(13) _
      & "エラーは、有りませんでした。", vbOKOnly
   Else
      MsgBox "処理が終了しました。" & Chr(13) _
      & "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。" & Chr(13) _
      & メッセージ & " で、エラーが有りました。", vbOKOnly + vbCritical
   End If

End Sub



Private Sub データのマッピングとファイル出力()
   Dim 出力データ配列() As String
   Dim 処理目 As Integer

      ReDim 出力データ配列(出力項目数)

      '★データのシートを開く★★
      Workbooks(対象ブック名).Worksheets(対象シート名).Activate

      出力開始行 = 開始行

      最終行 = Cells(ActiveSheet.Rows.Count, 列番号(データ最終行摘出列)).End(xlUp).Row

      Set 出力テキストストリームオブジェクト = _
      ファイルシステムオブジェクト.CreateTextFile(出力ファイル名)

      For 行 = 出力開始行 To 最終行

         For 処理目 = 1 To 出力項目数

            If Left(出力指定(処理目, 2), 1) = "\" Then
                  出力データ配列(処理目) = Right(出力指定(処理目, 2), Len(出力指定(処理目, 2)) - 1)
            ElseIf Len(出力指定(処理目, 2)) > 2 Then
                  出力データ配列(処理目) = 出力指定(処理目, 2)
            ElseIf 出力指定(処理目, 2) = "$" Then
               出力データ配列(処理目) = ""
            Else

               'フィルタによって処理を分ける

               If 出力指定(処理目, 3) = "" Then 'フィルタ指定無し

                  出力データ配列(処理目) = Range(出力指定(処理目, 2) & "1").Cells(行, 1).Value

               ElseIf 出力指定(処理目, 3) = "$" And 出力指定(処理目, 4) = False Then '空白を含めない
                  If CStr(Range(出力指定(処理目, 2) & "1").Cells(行, 1).Value) = "" Then
                     GoTo 次の行へ
                  Else
                     出力データ配列(処理目) = Range(出力指定(処理目, 2) & "1").Cells(行, 1).Value
                  End If
               ElseIf 出力指定(処理目, 3) = "$" And 出力指定(処理目, 4) = True Then '空白のみ含める
                  If CStr(Range(出力指定(処理目, 2) & "1").Cells(行, 1).Value) <> "" Then
                     GoTo 次の行へ
                  Else
                     出力データ配列(処理目) = Range(出力指定(処理目, 2) & "1").Cells(行, 1).Value
                  End If
               ElseIf 出力指定(処理目, 4) = True Then 'フィルタに合致するもののみ含める
                  If CStr(Range(出力指定(処理目, 2) & "1").Cells(行, 1).Value) <> 出力指定(処理目, 3) Then
                     GoTo 次の行へ
                  Else
                     出力データ配列(処理目) = Range(出力指定(処理目, 2) & "1").Cells(行, 1).Value
                  End If
               ElseIf 出力指定(処理目, 4) = False Then 'フィルタに不一致のもののみ含める
                  If CStr(Range(出力指定(処理目, 2) & "1").Cells(行, 1).Value) = 出力指定(処理目, 3) Then
                     GoTo 次の行へ
                  Else
                     出力データ配列(処理目) = Range(出力指定(処理目, 2) & "1").Cells(行, 1).Value
                  End If
               End If
            End If

         Next 処理目

         出力行 = ""

         If 出力形式 = 1 Then 'CSV 出力
            For 処理目 = 1 To 出力項目数
               If 処理目 = 1 Then
                  出力行 = Chr(34) & 出力データ配列(処理目) & Chr(34)
               Else
                  出力行 = 出力行 & "," & Chr(34) & 出力データ配列(処理目) & Chr(34)
               End If
            Next 処理目

         Else '固定長出力
            For 処理目 = 1 To 出力項目数
               If Len(出力データ配列(処理目)) > 出力指定(処理目, 1) Then
                  出力行 = 出力行 & Left(出力データ配列(処理目), 出力指定(処理目, 1))
                  Range(メッセージ列 & "1").Cells(行, 1).Value = _
                  Len(出力データ配列(処理目)) & " の先頭 " & 出力指定(処理目, 1) & " 桁のみ出力★"
                  メッセージ = メッセージ & CStr(出力データ配列(処理目)) & ","
               Else
                  出力行 = 出力行 & Left(出力データ配列(処理目) & Space(出力指定(処理目, 1)), 出力指定(処理目, 1))
               End If
            Next 処理目
         End If

         出力テキストストリームオブジェクト.WriteLine 出力行         ' 改行(CrLf)付き
次の行へ:
      Next 行

指定ファイルをCLOSE:
    出力テキストストリームオブジェクト.Close
    Set 出力テキストストリームオブジェクト = Nothing

End Sub

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

Excel VBA ファイル操作

テキストファイルの読み書き

英辞郎のテキスト・ファイルを、StarDict用 1行形式に変換する

PDICテキスト形式の EJDIC テキスト・ファイルを、StarDict用 1行形式に変換する

Excel の指定した列データを、CSV または 固定長でテキスト出力(汎用ツール)

Excel の指定した列データを、CSV または固定長でテキスト出力(汎用ツール)