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)」
https://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つのファイルに合体します。合体ファイルは、作業用フォルダ名をファイル名として、作成します。

EPWING 辞書複数行テキストを StarDict 1行テキストに変換 (UTF-8 ファイルの読み書き)も参照下さい。
こちら↑の方法を使えば、[参照設定]Microsoft ActiveX Data Objects Library は不要です。
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 レコードセット、レコード、およびストリーム オブジェクトを使用してドキュメントを開く方法
https://support.microsoft.com/kb/248255/ja

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


WriteText メソッド
指定したテキスト文字列を文字列型の Stream オブジェクトに書き込みます。

構文
Stream.WriteText Data, Options
パラメータ
Data
書き込む文字テキストを含む文字列型 (String) の値を指定します。
Options
省略可能です。指定した文字列の終わりに行区切り文字を書き込むかどうかを StreamWriteEnum 値で指定します。
StreamWriteEnum 定数 StreamWriteEnum 値 説明
adWriteChar 0 既定値で、行区切り文字は無しです。
Stream オブジェクトに対して、Data パラメータで指定したテキスト文字列を書き込みます。
adWriteLine 1 Stream オブジェクトに、テキスト文字列と行区切り文字を書き込みます。
LineSeparator プロパティが定義されていない場合は、実行時エラーを返します。
解説
指定した文字列が Stream オブジェクトに書き込まれます。このとき、各文字列間にスペースや文字は挿入されません。
現在の Position は、書き込まれたデータの次の文字に設定されます。WriteText メソッドでは、ストリーム内の残りの文字データは削除されません。これらの文字を削除する場合は、SetEOS メソッドを呼び出してください。
現在の EOS の位置を越える書き込みを行うと、StreamSize は、新しく書き込まれた文字がすべて格納されるように拡張され、EOS は、Stream に新しく書き込まれた最後の文字に移動します。

注意 WriteText メソッドは、文字列型ストリーム (TypeadTypeText) で使用します。バイナリ型のストリーム (TypeadTypeBinary) には、Write を使用してください。
バイナリ データを書き込む場合: Write メソッド


Option Explicit
Option Base 1
'********************************************************
Sub クイックソート(ByRef 配列() As Variant, ByVal 配列要素下限 As Long, ByVal 配列要素上限 As Long)
    Dim i As Long
    Dim j As Long
    Dim S As Variant
    Dim Tmp As Variant
    
        S = 配列(Int((配列要素下限 + 配列要素上限) / 2))
        i = 配列要素下限
        j = 配列要素上限
        Do
            Do While 配列(i) < S
                i = i + 1
            Loop
            Do While 配列(j) > S
                j = j - 1
            Loop
            If i >= j Then Exit Do
            Tmp = 配列(i)
            配列(i) = 配列(j)
            配列(j) = Tmp
            i = i + 1
            j = j - 1
      Loop
      If (配列要素下限 < i - 1) Then Call クイックソート(配列, 配列要素下限, i - 1)
      If (配列要素上限 > j + 1) Then Call クイックソート(配列, j + 1, 配列要素上限)
End Sub

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


(UTF-8 ファイルの読み書き) EPWING 辞書複数行テキストを StarDict 1行テキストに変換

 Windows パソコンの DDwin で使っていた「福武国語辞典 電子ブック版」の内容を、Android 電子書籍ブラウザの ColorDict で表示させるために、辞書データを変換するために作ったマクロです。
 電子ブックのキーは、「かな」しかありません。キーボードから検索語を入力するならそれでよいのですが、電子書籍からコピペするには、漢字キーも必要です。
 このため、このマクロを作って、よみ・漢字をひっくり返して、漢字キーを生成しました。
 生成したテキストは、StarDict Editor に渡して、辞書データに変換します。

このマクロをダウンロードできます→EPWINGtoStarDictVBA02.xls

EBDump で抽出したテキストを加工するバージョンもあります→EPWINGtoStarDictEBDumpVBA01.xls

Option Explicit
Option Base 1

'01:2024/04/30:ColorDict で串刺し検索するとき単語の完全一致をするので、キーをかなだけにする。
'02:2024/04/30:漢字に「読みがな」を付ける。しげい【至芸】


   Dim 漢字部分文字列 As String
   Dim 漢字キー数 As Integer
   Dim 漢字キー(20) As String
   Dim カウンタ As Integer
   
Sub StarDict用UTF8変換()

   Dim 入力ファイル名 As String
   Dim 出力ファイル名 As String
   Dim 入力行 As String
   Dim 出力行 As String
   Dim 出力行漢字 As String
   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant
   Dim 入力ADODBストリーム As Object                 ' ADODB.Stream
   Dim 出力ADODBストリーム As Object                 ' ADODB.Stream
   Dim 単語内行数 As Integer
   Dim 入力キー文字列 As String
   Dim 出力キー文字列 As String
   Dim 漢字部分開始文字目 As Integer
   Dim 漢字有 As Boolean
   Dim 読みがな As String

   '変換対象のファイル名とパス取得(ファイル名は決め打ち)
   入力ファイル名 = ThisWorkbook.Path & "\ddwin福武Export.txt"
   出力ファイル名 = ThisWorkbook.Path & "\FUKUTAKEforStarDict.txt"
      
   開始時刻 = Now()
   
   '********************************
   'かなキー生成
   '指定ファイルをOPEN(入力モード)
   'ADODB.Stream生成
   Set 入力ADODBストリーム = CreateObject("ADODB.Stream")
       
   With 入力ADODBストリーム
      .Type = 2             'adTypeText Textモード
      .Charset = "UTF-8"    '文字コード(Shift_JIS, Unicodeなど)
      .Open                 'Streamのオープン。入力ファイルのデフォルト改行は CRLF
      .LoadFromFile (入力ファイル名)
   End With
         
   ' 出力用の UTF-8 の"ADODB.Stream"オブジェクトを得る
   Set 出力ADODBストリーム = CreateObject("ADODB.Stream")
   
   'UTF-8形式で保存する
   With 出力ADODBストリーム
      .Type = 2            'adTypeText
      .Charset = "UTF-8"
      .Open
      .LineSeparator = 10  'adLF:LF (Unix)
   End With

   単語内行数 = 0
   出力行 = ""
   出力行漢字 = ""
   漢字キー数 = 0
   漢字有 = False
         
         '*************データの読み込み***********
    Do Until 入力ADODBストリーム.EOS

      ' レコードの読み込み
      入力行 = 入力ADODBストリーム.ReadText(-2)
      
'      If InStr(入力行, "アウト") > 0 Then GoTo 終了
        
      If Trim(入力行) = "" Then '空白行が来たところでその上の単語のデータを書き出す
         出力ADODBストリーム.WriteText 出力行, 1    '//0:改行無し 1:改行有り
         If 漢字有 = True Then
            出力ADODBストリーム.WriteText 出力行漢字, 1    '//0:改行無し 1:改行有り
            If 漢字キー数 > 1 Then '・で複数漢字キーが有った場合
               For カウンタ = 2 To 漢字キー数
'               Stop
                  出力行漢字 = Replace(出力行漢字, 漢字キー(カウンタ - 1), 漢字キー(カウンタ))
                  出力ADODBストリーム.WriteText 出力行漢字, 1    '//0:改行無し 1:改行有り
               Next カウンタ
            End If
         End If
'         Stop
         単語内行数 = 0
         出力行 = ""
         出力行漢字 = ""
         漢字キー数 = 0
         漢字有 = False
         '配列を初期化
         Erase 漢字キー
      Else
         単語内行数 = 単語内行数 + 1

         If 単語内行数 = 1 Then '単語キー
            If InStr(入力行, "【") > 1 Then '漢字部分有
               漢字有 = True
               漢字部分開始文字目 = InStr(入力行, "【") + 1
               漢字部分文字列 = Mid(入力行, 漢字部分開始文字目, Len(入力行) - 漢字部分開始文字目)
'               Stop
               出力行 = Left(入力行, 漢字部分開始文字目 - 2)
               読みがな = Left(入力行, 漢字部分開始文字目 - 2)
               If InStr(出力行, "〈") > 0 Then '〈あふ〉
                  出力行 = Left(出力行, InStr(出力行, "〈") - 1)
               End If
               出力行 = Replace(出力行, "・", "") '中点・を除去
               出力行 = 出力行 & vbTab & "【" & 漢字部分文字列 & "】"

               Call 漢字部分整形
               出力行漢字 = 漢字部分文字列
               
            Else '漢字部分無し
               If InStr(入力行, "〈") > 0 Then '〈あふ〉
                  入力行 = Left(入力行, InStr(入力行, "〈") - 1)
               End If
               入力行 = Replace(入力行, "・", "") '中点・を除去
               出力行 = 入力行
            End If
            
         ElseIf 単語内行数 = 2 Then  '意味初行
            If 漢字有 = False Then '漢字無し
               出力行 = 出力行 & vbTab & 入力行  'キーと意味の間はタブで区切る
            Else                   '漢字有り
               出力行 = 出力行 & "\n" & 入力行  '改行を挟む
            End If
            If 読みがな = "" Then
               出力行漢字 = 漢字部分文字列 & vbTab & 入力行  'キーと意味の間はタブで区切る
            Else
               出力行漢字 = 漢字部分文字列 & vbTab & "【" & 読みがな & "】" & "\n" & 入力行
            End If
         Else  '意味2行目以降
            出力行 = 出力行 & "\n" & 入力行
            出力行漢字 = 出力行漢字 & "\n" & 入力行
         End If
      End If
        ' 最終行まで繰り返す
   Loop
   
'終了:
   
   出力ADODBストリーム.SaveToFile (出力ファイル名), 2 'adSaveCreateOverWrite 上書きを許す
        
   ' 指定ファイルをCLOSE
   入力ADODBストリーム.Close
   Set 入力ADODBストリーム = Nothing
   
   出力ADODBストリーム.Close
   Set 出力ADODBストリーム = Nothing

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

End Sub


Private Sub 漢字部分整形()
   Dim 作業文字列 As String

   Dim キー漢字 As String
   Dim キーかな As String
   Dim 意味部分文字列 As String
   
   '全角のアルファベット(英字)を半角に変換する
   'http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_zenkakueisuji.html
   作業文字列 = ""
   For カウンタ = 1 To Len(漢字部分文字列)
      If Mid(漢字部分文字列, カウンタ, 1) Like "[A-z]" Then
         作業文字列 = 作業文字列 & StrConv(Mid(漢字部分文字列, カウンタ, 1), vbNarrow)
      Else
         作業文字列 = 作業文字列 & Mid(漢字部分文字列, カウンタ, 1)
      End If
   Next カウンタ
   漢字部分文字列 = 作業文字列

   漢字部分文字列 = Replace(漢字部分文字列, "▼", "") '中点・以外を除去
   漢字部分文字列 = Replace(漢字部分文字列, "∇", "")
   漢字部分文字列 = Replace(漢字部分文字列, "〈", "")
   漢字部分文字列 = Replace(漢字部分文字列, "〉", "")
   漢字部分文字列 = Replace(漢字部分文字列, "《", "")
   漢字部分文字列 = Replace(漢字部分文字列, "》", "")
   
   漢字キー数 = 1
   Do While InStr(漢字部分文字列, "・") > 0
      '漢字単語が複数
'      Stop
      漢字キー(漢字キー数) = Left(漢字部分文字列, InStr(漢字部分文字列, "・") - 1)
      漢字部分文字列 = Right(漢字部分文字列, Len(漢字部分文字列) - InStr(漢字部分文字列, "・"))
      漢字キー数 = 漢字キー数 + 1
   Loop
   If 漢字キー数 > 1 Then
      漢字キー(漢字キー数) = 漢字部分文字列
      漢字部分文字列 = 漢字キー(1)
   End If

End Sub

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


(UTF-8 ファイル読み書き) デジタル大辞泉のhtmlを StarDict 1行テキストに変換

デジタル大辞泉  パソコンのハードディスクを整理していて下記のサイズが大きい(72MB) html ファイルを見つけました。
C:\Users\名前\.ebookreader\books\a33752e5c6e1cf37ed848680f951ebd8\a33752e5c6e1cf37ed848680f951ebd8.html
 内容を確認すると「デジタル大辞泉」の html でした。
どうしてこのファイルが保存されているのか記憶がないのですが、html だと参照が難しいので StarDict 用の辞書ファイルに加工して使えるようにしました。
 総項目数23万余語を収めた辞書をオフラインで使えるようになりました。

 html の内容は下記のようになっています。


おお‐おく【大奥】〔おほ‐〕
江戸城内で、将軍の御台所(みだいどころ)(正妻)や側室が居住した所。将軍を除き、男子禁制。
貴人の奥方の居所。また、その奥方。

 html はファイル中に改行コードが入っていないので、まずテキスト・エディタで項目の区切り(<a ></a> の直前)に改行コード(CRLF)を入れた後、下記のマクロで順を追って加工していきます。
1.単語と説明に分けて必要部分を抽出して StarDict 1行テキストに変換する。
これを StarDict Editor に掛けると、行データの重複のエラーが検出されてコンパイルできませんでした。

 このため、重複行を削除するために下記のマクロを作りました。
2.テキスト・ファイルをソートする。
3.ソートされたファイルから重複行を削除して書き出す。


このマクロをダウンロードできます→DaiJiSenToOneLineVBA07.xls


Option Explicit

'03:2014/04/28:<a name="0000512477"> </a> の形式を前もって削除。悪事を働く者の仲間

Sub 大辞泉→1行化()

   Dim 入力ADODBストリーム As Object             ' ADODB.Stream
   Dim 出力ADODBストリーム As Object             ' ADODB.Stream
   Dim 入力ファイル名 As String
   Dim 出力ファイル名 As String
   Dim 入力行 As String
   Dim 出力行 As String
   Dim 前出力行 As String
   Dim 処理行カウンタ As Long
   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant
   Dim 単語 As String

   Dim 単語部分文字目 As Integer
   Dim 終り括弧文字目 As Integer
   Dim 訳語 As String
   Dim 訳語部分 As String
   Dim 最後の訳語 As String

   Application.DisplayStatusBar = True
   
    '決め打ち
   ChDrive ThisWorkbook.Path
   ChDir ThisWorkbook.Path
   入力ファイル名 = "index-Original.html"
   出力ファイル名 = "デジタル大辞泉.txt"
       
   開始時刻 = Now()
   
   '********************************
   'ファイルのオープン。
   処理行カウンタ = 0
   
   ' 指定ファイルをOPEN(入力モード)
   Set 入力ADODBストリーム = CreateObject("ADODB.Stream")
    
   With 入力ADODBストリーム
      .Type = 2          'adTypeText Textモード
      .Charset = "UTF-8" '文字コード(Shift_JIS, Unicodeなど)
      .Open              'Streamのオープン
      .LoadFromFile (入力ファイル名)
   End With

   ' 指定ファイルをOPEN(出力モード)
   Set 出力ADODBストリーム = CreateObject("ADODB.Stream")
   'UTF-8形式で保存する
   With 出力ADODBストリーム
      .Type = 2            'adTypeText
      .Charset = "UTF-8"
      .Open
      .LineSeparator = 10  'adLF:LF (Unix)
   End With

   '*************データの読み込み***********
   Do Until 入力ADODBストリーム.EOS
      処理行カウンタ = 処理行カウンタ + 1
        
      出力行 = ""
      ' レコードの読み込み
      入力行 = 入力ADODBストリーム.ReadText(-2) '-2 adReadLine
      
'      If InStr(入力行, ChrW(&H25E6)) > 0 Then Stop
      '<a name="0000512477">&nbsp;</a> の形式を前もって削除。悪事を働く者の仲間
      入力行 = 正規表現で置換(入力行, "<a name=""[0-9]{10}"">&nbsp;</a>", "")

      If Left(入力行, 12) = "<a ></a> <b>" Then
         単語部分文字目 = InStr(入力行, "</b>")
         単語 = Mid(入力行, 13, 単語部分文字目 - 13)
         単語 = Replace(単語, ChrW(&H25E6), "")     '不要マークを削除
         単語 = Replace(単語, "・", "")             '不要マークを削除
         単語 = Replace(単語, "‐", "")             '不要マークを削除
         単語 = 正規表現で置換(単語, "<(.*?)>", "") 'html タグを除去
         単語 = Trim(単語)

         訳語部分 = LTrim(Right(入力行, Len(入力行) - 単語部分文字目 - 3))
'         Stop
         If Left(訳語部分, 4) = "<br>" Then '単語の直後の"<br>"は除去
            訳語部分 = Trim(Right(訳語部分, Len(訳語部分) - 4))
         End If
         訳語部分 = Replace(訳語部分, "<br>", "\n") '前もって改行タグを修正
         訳語部分 = Replace(訳語部分, "&nbsp;", " ")         '&nbsp; を削除
'         Stop
         訳語部分 = 正規表現で置換(訳語部分, "<(.*?)>", "") 'html タグを除去
         訳語部分 = Trim(訳語部分)
'         Stop
         出力行 = 単語 & vbTab & 訳語部分
'         Stop
         If 前出力行 <> 出力行 Then
            出力ADODBストリーム.WriteText 出力行, 1    '//0:改行無し 1:改行有り
            前出力行 = 出力行
         End If

      ElseIf Left(入力行, 13) = "<a ></a> *<b>" Then
         単語部分文字目 = InStr(入力行, "</b>")
         単語 = Trim(Mid(入力行, 14, InStr(入力行, "</b>") - 14))
         単語 = Replace(単語, ChrW(&H25E6), "")     '不要マークを削除
         単語 = Replace(単語, "・", "")             '不要マークを削除
         単語 = Replace(単語, "‐", "")             '不要マークを削除
         単語 = Replace(単語, "&nbsp;", " ")         '<a name="0030332276">&nbsp;</a>部分を削除
         単語 = 正規表現で置換(単語, "<(.*?)>", "") 'html タグを除去
         単語 = Trim(単語)

         訳語部分 = LTrim(Right(入力行, Len(入力行) - 単語部分文字目 - 3))
'         Stop
         If Left(訳語部分, 4) = "<br>" Then '単語の直後の"<br>"は除去
            訳語部分 = Trim(Right(訳語部分, Len(訳語部分) - 4))
         End If
         訳語部分 = Replace(訳語部分, "<br>", "\n") '前もって改行タグを修正
         訳語部分 = Replace(訳語部分, "&nbsp;", "")         '&nbsp; を削除
'         Stop
         訳語部分 = 正規表現で置換(訳語部分, "<(.*?)>", "") 'html タグを除去
         訳語部分 = Trim(訳語部分)
'         Stop
         出力行 = 単語 & vbTab & 訳語部分
'         Stop
         If 前出力行 <> 出力行 Then
            出力ADODBストリーム.WriteText 出力行, 1    '//0:改行無し 1:改行有り
            前出力行 = 出力行
         End If

      End If
      
      If (処理行カウンタ Mod 10000) = 0 Then
         Application.StatusBar = 処理行カウンタ & " 行目を読込み"
      End If
        
        ' 最終行まで繰り返す
   Loop
   
   Application.StatusBar = "カナ部分終了 " & 処理行カウンタ & " 行目を読込み"
    ' 指定ファイルをCLOSE
    入力ADODBストリーム.Close
    
   '*********************************************
   '漢字索引用に再度読み込む
   
   処理行カウンタ = 0
   With 入力ADODBストリーム
      .Type = 2          'adTypeText Textモード
      .Charset = "UTF-8" '文字コード(Shift_JIS, Unicodeなど)
      .Open              'Streamのオープン
      .LoadFromFile (入力ファイル名)
   End With
   
   Do Until 入力ADODBストリーム.EOS
      処理行カウンタ = 処理行カウンタ + 1
        
      出力行 = ""
      ' レコードの読み込み
      入力行 = 入力ADODBストリーム.ReadText(-2) '-2 adReadLine
      '<a name="0030332276">&nbsp;</a>部分を削除
      入力行 = 正規表現で置換(入力行, "<a name=""[0-9]{10}"">&nbsp;</a>", "")
      
      If Left(入力行, 12) = "<a ></a> <b>" Then
         単語部分文字目 = InStr(入力行, "</b>")
         単語 = Mid(入力行, 13, 単語部分文字目 - 13)
         単語 = 正規表現で置換(単語, "<(.*?)>", "") 'html タグを除去
         単語 = Replace(単語, "&nbsp;", " ")        '&nbsp;を削除
         単語 = Trim(単語)
         
         訳語部分 = LTrim(Right(入力行, Len(入力行) - 単語部分文字目 - 3))
'         Stop
         If Left(訳語部分, 4) = "<br>" Then '単語の直後の"<br>"は除去
            訳語部分 = Trim(Right(訳語部分, Len(訳語部分) - 4))
         End If
         訳語部分 = Replace(訳語部分, "<br>", "\n") '前もって改行タグを修正
         訳語部分 = Replace(訳語部分, "&nbsp;", "")         '&nbsp; を削除
'         Stop
         訳語部分 = 正規表現で置換(訳語部分, "<(.*?)>", "") 'html タグを除去
         訳語部分 = Trim(訳語部分)
         
         If Left(訳語部分, 1) = "【" Then
            終り括弧文字目 = InStr(訳語部分, "】")
            単語 = Mid(訳語部分, 2, 終り括弧文字目 - 2)
'            Stop
            単語 = Replace(単語, "▽", "")
            単語 = Replace(単語, "×", "")
            単語 = Trim(単語)
            
            If 単語 <> "" Then
   '            Stop
               訳語部分 = Right(訳語部分, Len(訳語部分) - 終り括弧文字目)
   '            Stop
               If Left(訳語部分, 2) = "\n" Then
                  訳語部分 = Right(訳語部分, Len(訳語部分) - 2)
               ElseIf Left(訳語部分, 3) = " \n" Then
                  訳語部分 = Right(訳語部分, Len(訳語部分) - 3)
               End If
   '            Stop
               出力行 = 単語 & vbTab & Trim(訳語部分)
   '            Stop
               If 前出力行 <> 出力行 Then
                  出力ADODBストリーム.WriteText 出力行, 1    '//0:改行無し 1:改行有り
                  前出力行 = 出力行
               End If
            End If
         End If

      End If
      
      If (処理行カウンタ Mod 10000) = 0 Then
         Application.StatusBar = "漢字索引で " & 処理行カウンタ & " 行目を読込み"
      End If
        
        ' 最終行まで繰り返す
   Loop
   
   '*********************************************

   出力ADODBストリーム.SaveToFile (出力ファイル名), 2 'adSaveCreateOverWrite 上書きを許す
    
    '**************終了処理*********************
    Application.StatusBar = 処理行カウンタ & " 最終行まで読込み完了"
    
    ' 指定ファイルをCLOSE
    入力ADODBストリーム.Close
    Set 入力ADODBストリーム = Nothing
    出力ADODBストリーム.Close
    Set 出力ADODBストリーム = Nothing
    
    終了時刻 = Now()
    MsgBox "処理が終了しました。" & Chr(13) & _
    "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
    
End Sub

Option Explicit
Option Base 1

'04:2014/04/28:ソート前配列への登録方法を1行ずつに変更

'VBA UTF-8のテキストファイルをソートして出力する

Sub ファイルソート()
   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant
   Dim 入力ファイル名 As String
   Dim 出力ファイル名 As String
   Dim 配列(500000) As String
   Dim 文字列 As Variant
   Dim 入力ADODBストリーム As Object             ' ADODB.Stream
   Dim 出力ADODBストリーム As Object             ' ADODB.Stream
   Dim 処理行カウンタ As Long
   
   開始時刻 = Now()
   Application.DisplayStatusBar = True
   
   '入出力ファイル名は決め打ち
   ChDrive ThisWorkbook.Path
   ChDir ThisWorkbook.Path
   入力ファイル名 = "デジタル大辞泉.txt"
   出力ファイル名 = "デジタル大辞泉ソート済.txt"
   
   'ファイル読み込み(UTF-8はADODB.Streamを使う)
   Set 入力ADODBストリーム = CreateObject("ADODB.Stream")
   
   With 入力ADODBストリーム
      .Type = 2          'adTypeText Textモード
      .Charset = "UTF-8" '文字コード(Shift_JIS, Unicodeなど)
      .Open              'Streamのオープン
      .LoadFromFile (入力ファイル名)
      .LineSeparator = 10  'adLF:LF (Unix)
   End With
'      LineSeparator adCR  13    改行復帰を示します。
'                    adCRLF   -1 「既定値」です。改行復帰行送りを示します。
'                    adLF  10    行送りを示します。

   処理行カウンタ = 0
   Do Until 入力ADODBストリーム.EOS
      処理行カウンタ = 処理行カウンタ + 1

      文字列 = 入力ADODBストリーム.ReadText(-2) '-2 adReadLine
      配列(処理行カウンタ) = 文字列
      If (処理行カウンタ Mod 10000) = 0 Then
         Application.StatusBar = 処理行カウンタ & " 行目を読込み"
      End If
        ' 最終行まで繰り返す
   Loop
   
   入力ADODBストリーム.Close
   Application.StatusBar = "★ 入力ファイルの読込み終了 ★" & 処理行カウンタ & " 行"
   
   Debug.Print "処理行カウンタ= ", 処理行カウンタ

   'ソート
   Call 文字Sort(配列, 1, 処理行カウンタ, 0)

   '保存
   Set 出力ADODBストリーム = CreateObject("ADODB.Stream")
   
   'UTF-8形式で保存する
   With 出力ADODBストリーム
      .Type = 2            'adTypeText
      .Charset = "UTF-8"
      .Open
      .LineSeparator = 10  'adLF:LF (Unix)
   End With
   
   For Each 文字列 In 配列
      If 文字列 <> "" Then
         出力ADODBストリーム.WriteText 文字列 & vbLf, 0
      End If
   Next
   出力ADODBストリーム.SaveToFile 出力ファイル名, 2
   出力ADODBストリーム.Close

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

End Sub


'配列引数「処理配列」のソートを実施

'************************************************
'★★★文字ソート★★★
Private Sub 文字Sort _
    (ByRef テキスト配列() As String, _
     ByVal 開始行 As Long, _
     ByVal 終了行 As Long, _
     比較モード As Integer)

   '林道の鬼
   'http://www.geocities.co.jp/SilkRoad/4511/vb/strsort.htm
   'をそのまま使わせていただいています。
   '----- StrSort Ver 1.00 -----
   '文字列型(String)配列をソートします。
   '
   '引数 テキスト配列()
   '   ソート対象となる文字列型(String)配列を指定します。
   '       テキスト配列(0) = "Error"
   '       テキスト配列(1) = "Aho no Sakata"
   '       テキスト配列(2) = "Cool"
   '   の配列を渡した場合、
   '       テキスト配列(0) = "Aho no Sakata"
   '       テキスト配列(1) = "Cool"
   '       テキスト配列(2) = "Error"
   '   のように正順に整列されます。
   '
   '引数 開始行
   '   ソートを開始する配列の要素番号を指定します。
   '
   '引数 終了行
   '   ソートを終了する配列の要素番号を指定します。
   '
   '引数 比較モード
   '   省略可能です。文字列比較のモードを指定する番号を設定します。
   '
   '   0, vbBinaryCompare - バイナリ モードの比較を行います。(大文字/小文字を区別する)
   '   1, vbTextCompare   - テキスト モードの比較を行います。大文字/小文字を区別せず比較
   '
   '   この引数を省略すると vbBinaryCompare が適用されます。
   '
   'ソートにはクイックソートアルゴリズムを使用し、文字列比較には
   'StrComp 関数を使用しています。ソートアルゴリズム自体は
   '高速なのですが、可変長文字列型配列を扱うため処理速度はそこそこ。

 Dim 中央の要素番号 As Long                                   '中央の要素番号を格納する変数
 Dim 基準値 As String                                         '基準値を格納する変数
 Dim 格納位置カウンタ As Long                                 '格納位置カウンタ
 Dim 一時待避 As String                                       '値をスワップするための作業域
 Dim i As Long                                                'ループカウンタ
 
    If 開始行 >= 終了行 Then Exit Sub                         '終了番号が開始番号以下の場合、プロシージャを抜ける
    中央の要素番号 = (開始行 + 終了行) \ 2                    '中央の要素番号を求める
    基準値 = テキスト配列(中央の要素番号)                     '中央の値を基準値とする
    テキスト配列(中央の要素番号) = テキスト配列(開始行)       '中央の要素に開始番号の値を格納
    格納位置カウンタ = 開始行                                 '格納位置カウンタを開始番号と同じにする
    For i = (開始行 + 1) To 終了行 Step 1                     '開始番号の次の要素から終了番号までループ
        If StrComp(テキスト配列(i), 基準値, 比較モード) = -1 Then         '値が基準値より小さい場合
            格納位置カウンタ = 格納位置カウンタ + 1           '格納位置カウンタをインクリメント
            一時待避 = テキスト配列(格納位置カウンタ)         'テキスト配列(i) と テキスト配列(格納位置カウンタ) の値をスワップ
            テキスト配列(格納位置カウンタ) = テキスト配列(i)
            テキスト配列(i) = 一時待避
        End If
    Next
    テキスト配列(開始行) = テキスト配列(格納位置カウンタ)     'テキスト配列(格納位置カウンタ) を開始番号の値にする
    テキスト配列(格納位置カウンタ) = 基準値                   '基準値を テキスト配列(格納位置カウンタ) に格納
    Call 文字Sort(テキスト配列, 開始行, 格納位置カウンタ - 1, 比較モード)  '分割された配列をクイックソート(再帰)
    Call 文字Sort(テキスト配列, 格納位置カウンタ + 1, 終了行, 比較モード)  '分割された配列をクイックソート(再帰)

End Sub

 解説:
StrComp 関数 は文字列比較の結果を示す、サブタイプが整数型 (Integer) であるバリアント型 (Variant) の値を返します。

 構文    StrComp(string1, string2, [ compare ])

 StrComp 関数の構文には、次の名前付き引数があります。
パーツ 説明
string1 必須です。 任意の有効な文字列式を指定します。
string2 必須。 任意の有効な文字列式を指定します。
compare 省略可能。 文字列比較の種類を指定します。 compare引数Null の場合、エラーが発生します。 compare が省略された場合、Option Compare 設定は比較のタイプを決定します。
Settings
 compare 引数の設定値は以下のとおりです。
定数 説明
vbUseCompareOption -1 Option Compare ステートメントの設定を使用して比較を実行します。
vbBinaryCompare 0 バイナリ比較を実行します。
vbTextCompare 1 テキスト比較を実行します。
vbDatabaseCompare 2 Microsoft Access のみ。 データベース内の情報に基づいて比較を実行します。
渡辺注:バイナリ比較を使うなら、StrComp でなく単純な大小比較 <= を使っても結果は同じでした。

戻り値
 StrComp 関数の戻り値は次のとおりです。
条件 StrComp の戻り値
string1string2 より小さい -1
string1string2 と等しい 0
string1string2 より大きい 1
string1 または string2Null である Null

 次の例では、StrComp 関数を使用して文字列比較の結果を取得します。
3 番目の引数が 1 の場合はテキスト比較が実行され、0 または省略された場合はバイナリ比較が実行されます。
Dim MyStr1, MyStr2, MyComp
MyStr1 = "ABCD": MyStr2 = "abcd"    ' Define variables.
MyComp = StrComp(MyStr1, MyStr2, 1)    ' Returns 0.
MyComp = StrComp(MyStr1, MyStr2, 0)    ' Returns -1.
MyComp = StrComp(MyStr2, MyStr1)    ' Returns 1.
クイック・ソート(大小比較 <= を使う)
Private Sub 文字行Sort(配列() As String, 開始行 As Long, 終了行 As Long)
   'QuickSort
   Dim i As Long, j As Long
   Dim 基準値 As String, 一時待避 As String
   
   If 開始行 < 終了行 Then
      基準値 = 配列((開始行 + 終了行) \ 2)
      i = 開始行
      j = 終了行
      Do While i <= j
         Do While 配列(i) < 基準値
             i = i + 1
         Loop
         Do While 配列(j) > 基準値
             j = j - 1
         Loop
         If i <= j Then
             一時待避 = 配列(i)
             配列(i) = 配列(j)
             配列(j) = 一時待避
             i = i + 1
             j = j - 1
         End If
      Loop
      Call 文字行Sort(配列, 開始行, j)
      Call 文字行Sort(配列, i, 終了行)
   End If
End Sub

Option Explicit

Sub ソート済ファイルの重複削除()

   Dim ファイルシステムオブジェクト As Object    ' FileSystemObject
   Dim 入力ADODBストリーム As Object             ' ADODB.Stream
   Dim 出力ADODBストリーム As Object             ' ADODB.Stream
   Dim 入力ファイル名 As String
   Dim 出力ファイル名 As String
   Dim 入力行 As String
   Dim 前入力行 As String
   Dim 処理行カウンタ As Long
   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant

   Application.DisplayStatusBar = True
   
    '決め打ち
   ChDrive ThisWorkbook.Path
   ChDir ThisWorkbook.Path
   入力ファイル名 = "デジタル大辞泉ソート済.txt"
   出力ファイル名 = "DaiJiSen.txt"
       
   開始時刻 = Now()

   '********************************
   'ファイルのオープン。
   処理行カウンタ = 0
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   ' 指定ファイルをOPEN(入力モード)
   Set 入力ADODBストリーム = CreateObject("ADODB.Stream")
    
   With 入力ADODBストリーム
      .Type = 2          'adTypeText Textモード
      .Charset = "UTF-8" '文字コード(Shift_JIS, Unicodeなど)
      .Open              'Streamのオープン
      .LoadFromFile (入力ファイル名)
      .LineSeparator = 10  'adLF:LF (Unix)
   End With
'      LineSeparator adCR  13    改行復帰を示します。
'                    adCRLF   -1 「既定値」です。改行復帰行送りを示します。
'                    adLF  10    行送りを示します。

   ' 指定ファイルをOPEN(出力モード)
   Set 出力ADODBストリーム = CreateObject("ADODB.Stream")
   'UTF-8形式で保存する
   With 出力ADODBストリーム
      .Type = 2            'adTypeText
      .Charset = "UTF-8"
      .Open
      .LineSeparator = 10  'adLF:LF (Unix)
   End With

   '*************データの読み込み***********
   前入力行 = ""
   
   Do Until 入力ADODBストリーム.EOS
      処理行カウンタ = 処理行カウンタ + 1
        
      ' レコードの読み込み
      入力行 = 入力ADODBストリーム.ReadText(-2) '-2 adReadLine
      
      If 前入力行 <> 入力行 Then
         出力ADODBストリーム.WriteText 入力行, 1    '//0:改行無し 1:改行有り
         前入力行 = 入力行
      End If

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

        ' 最終行まで繰り返す
   Loop
   
   '*********************************************

   出力ADODBストリーム.SaveToFile (出力ファイル名), 2 'adSaveCreateOverWrite 上書きを許す
    
    '**************終了処理*********************
    Application.StatusBar = 処理行カウンタ & " 最終行まで読込み完了"
    
    ' 指定ファイルをCLOSE
    入力ADODBストリーム.Close
    Set 入力ADODBストリーム = Nothing
    出力ADODBストリーム.Close
    Set 出力ADODBストリーム = Nothing
    
    Set ファイルシステムオブジェクト = Nothing

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

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


(UTF-8 ファイルに追記) UTF-8ファイルを読んで、指定文字列を含む行を抽出して出力

教えていただいたサイト
 UTF-8形式のテキストファイルに書き込む
http://officetanaka.net/excel/vba/file/file11.htm

このマクロをダウンロードできます→ExtractLinesOfSpecifiedCharactersVBA00.xls

Option Explicit

   Dim ファイル名 As String
   Dim キーの文字列 As String
   
Sub 現在のフォルダの直下の全てのファイルを対象に処理()

   Dim 対象ファイルの拡張子 As String
   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim このExcelブックのフォルダパス As String
   Dim フォルダ As Object
   Dim ファイル As Object
   Dim ファイル数 As Long
   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant

    開始時刻 = Now                ' 開始時刻を変数に格納します。
    Application.DisplayStatusBar = True
   
   '★指定した html の存在するフォルダの全ての html ファイルを対象
   ファイル数 = 0
   
   ThisWorkbook.Worksheets("Sheet1").Activate
   対象ファイルの拡張子 = Range("D3").Value
   キーの文字列 = Range("D4").Value
   
   このExcelブックのフォルダパス = ThisWorkbook.Path
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(このExcelブックのフォルダパス)
   
   For Each ファイル In フォルダ.Files
   
      ファイル名 = ファイル.Name

      'ファイルの拡張子を調べて、html ファイルのみを、取得対象とする
      If Right(ファイル名, Len(ファイル名) - InStrRev(ファイル名, ".")) = 対象ファイルの拡張子 Then
      
         'ファイルが、対象ファイルだったら
         ファイル数 = ファイル数 + 1
         
         If ファイル数 Mod 1000 = 0 Then
            Application.StatusBar = "★☆★" & ファイル数 & " を処理しました。"
         End If
         
         Call 指定したキー文字列を含む行を書き出す

      End If '指定拡張子のファイルのみ
      
   Next '★ファイル

    '**************終了処理*********************
    
   'オブジェクトを解放する
   Set フォルダ = Nothing
   Set ファイルシステムオブジェクト = Nothing

    終了時刻 = Now()
    MsgBox "処理が終了しました。" & Chr(13) & _
    "対象ファイル数: " & ファイル数 & Chr(13) & _
    "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
    
End Sub

Private Sub 指定したキー文字列を含む行を書き出す()

   Dim 入力ファイル名 As String
   Dim 出力ファイル名 As String
   Dim 入力行 As String
   Dim 入力ADODBストリーム As Object                 ' ADODB.Stream
   Dim 出力ADODBストリーム As Object                 ' ADODB.Stream

   '変換対象のファイル名とパス取得(出力ファイル名は決め打ち)
   入力ファイル名 = ThisWorkbook.Path & "\" & ファイル名
   出力ファイル名 = ThisWorkbook.Path & "\出力テキスト.txt"
      
   '********************************
   ' 指定ファイルをOPEN(入力モード)
   'ADODB.Stream生成
   Set 入力ADODBストリーム = CreateObject("ADODB.Stream")
       
   With 入力ADODBストリーム
      .Type = 2             'adTypeText Textモード
      .Charset = "UTF-8"    '文字コード(Shift_JIS, Unicodeなど)
      .Open                 'Streamのオープン
      .LoadFromFile (入力ファイル名)
   End With
         
   ' 出力用の UTF-8 の"ADODB.Stream"オブジェクトを得る
   Set 出力ADODBストリーム = CreateObject("ADODB.Stream")
   
   'UTF-8形式で保存する
   With 出力ADODBストリーム
      .Type = 2                    'adTypeText
      .Charset = "UTF-8"
      .Open
      .LineSeparator = 10          'adLF:LF (Unix)
   End With
   
   If Dir(出力ファイル名) <> "" Then '出力ファイルが既存
      With 出力ADODBストリーム
         .LoadFromFile 出力ファイル名 'まず既存データを全部読み込む
         .Position = .Size            '書き込み位置をデータの末尾に移動させる
      End With
   End If

    '*************データの読み込み***********
    Do Until 入力ADODBストリーム.EOS

      ' レコードの読み込み
      入力行 = 入力ADODBストリーム.ReadText(-2) 'adReadLine:ストリームから次の行を読み込み。
      '-1 (adReadAll)だと現在の位置からEOSマーカー方向に、すべてのバイトをストリームから読み込みます。

      If InStr(入力行, キーの文字列) > 0 Then
         出力ADODBストリーム.WriteText 入力行, 1    '//0:改行無し 1:改行有り
      End If
        ' 最終行まで繰り返す
   Loop
        
   出力ADODBストリーム.SaveTofile (出力ファイル名), 2 'adSaveCreateOverWrite 上書きを許す
        
   ' 指定ファイルをCLOSE
   入力ADODBストリーム.Close
   Set 入力ADODBストリーム = Nothing
   
   出力ADODBストリーム.Close
   Set 出力ADODBストリーム = Nothing

End Sub

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

(UTF-8 ファイルに追記) 英文 HTML に、Google で作成した英和対訳ファイルの日本語部分を挿入して出力

プロジェクト・グーテンベルクでは、無償の電子書籍を公開しています。
著作権が切れた作品を中心に、世界の偉大な文学を、ここで見つけることができます。

ここに、「みつばちマーヤの冒険」の英文訳 The Adventures of Maya the Bee がありました。
(『みつばちマーヤの冒険』は、ハンブルク生まれの作家、児童文学者のワルデマル・ボンゼルスが1912年に発表した(原題:Die Biene Maja und ihre Abenteuer、『みつばちマーヤとその冒険』)
https://www.gutenberg.org/ebooks/22354

この中の「Read this book online: HTML (as submitted)」を使って、GAS(Google Apps Script) に渡すと、英和対訳ファイルを作成できます。

このマクロは、最初に英和対訳ファイルを読んで、英文の最後の単語と和文の配列(辞書)を作成します。
次に英文HTMLを読んで英文の最後の単語をキーに、先に作成済の配列から和文を挿入していきます。
注意点としては、HTML には文字強調などのタブが入っているので、HTML 解析時にはこの不要なタブを除去して処理しています。

このマクロを含む関連ファイルをダウンロードできます→TheAdventuresOfMayaTheBeeE&J.zip

追記Sigil を使うと、簡単に HTML を ePub に変換できます。

Option Explicit

' 00:2023/08/06:作成

Sub 英文HTMLに対訳和文を挿入()

   Dim 入力対訳ファイル名 As String
   Dim 入力英文ファイル名 As String
   Dim 出力ファイル名 As String
   Dim 入力対訳行 As String
   Dim 入力英文行 As String
   Dim 作業文字列 As String
   Dim 出力行 As String
   Dim 対訳(2000, 2) As String
   Dim 対訳数 As Integer
   Dim 本文 As String

   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant
   Dim 入力対訳ADODBストリーム As Object                 ' ADODB.Stream
   Dim 入力英文ADODBストリーム As Object                 ' ADODB.Stream
   Dim 出力ADODBストリーム As Object                 ' ADODB.Stream
   Dim 英文行末語 As String
   Dim 検索数 As Integer

   '変換対象のファイル名とパス取得(ファイル名は決め打ち)
   入力対訳ファイル名 = ThisWorkbook.Path & "\The Adventures of Maya the Bee対訳.txt"
   入力英文ファイル名 = ThisWorkbook.Path & "\The Adventures of Maya the Bee, by Waldemar Bonsels.html"
   出力ファイル名 = ThisWorkbook.Path & "\The Adventures of Maya the Bee, by Waldemar Bonsels=E2J.html"
      
   開始時刻 = Now()
   
   '********************************
   ' 指定ファイルをOPEN(入力モード)
   'ADODB.Stream生成
   Set 入力対訳ADODBストリーム = CreateObject("ADODB.Stream")
   Set 入力英文ADODBストリーム = CreateObject("ADODB.Stream")
   With 入力対訳ADODBストリーム
      .Type = 2             'adTypeText Textモード
      .Charset = "UTF-8"    '文字コード(Shift_JIS, Unicodeなど)
      .Open                 'Streamのオープン
      .LoadFromFile (入力対訳ファイル名)
   End With
   With 入力英文ADODBストリーム
      .Type = 2             'adTypeText Textモード
      .Charset = "UTF-8"    '文字コード(Shift_JIS, Unicodeなど)
      .Open                 'Streamのオープン
      .LineSeparator = 10   'adLF:LF (Unix)
      .LoadFromFile (入力英文ファイル名)
   End With
   ' 出力用の UTF-8 の"ADODB.Stream"オブジェクトを得る
   Set 出力ADODBストリーム = CreateObject("ADODB.Stream")
   
   'UTF-8形式で保存する
   With 出力ADODBストリーム
      .Type = 2            'adTypeText
      .Charset = "UTF-8"
      .Open
      .LineSeparator = 10  'adLF:LF (Unix)
   End With


    '*************対訳データの読み込み***********
   対訳数 = 0
   Do Until 入力対訳ADODBストリーム.EOS

      ' レコードの読み込み
      入力対訳行 = 入力対訳ADODBストリーム.ReadText(-2)
'      Stop
      If Trim(入力対訳行) <> "" Then
      入力対訳行 = Trim(入力対訳行)
      
         If InStrRev(入力対訳行, " ") > 0 Then
            英文行末語 = Right(入力対訳行, Len(入力対訳行) - InStrRev(入力対訳行, " "))
         Else
            英文行末語 = 入力対訳行
         End If
         
         対訳数 = 対訳数 + 1
         対訳(対訳数, 1) = 英文行末語
         対訳(対訳数, 2) = Trim(入力対訳ADODBストリーム.ReadText(-2))

      End If
        ' 最終行まで繰り返す
   Loop
   
'   Stop
    '*************HTML データの読み込み***********
   本文 = ""
   検索数 = 0
   Do Until 入力英文ADODBストリーム.EOS
      出力行 = ""
      ' レコードの読み込み
      入力英文行 = 入力英文ADODBストリーム.ReadText(-2)
      
      '入力HTMLから不要なタグを除去
      作業文字列 = Replace(入力英文行, "<i>", "")
      作業文字列 = Replace(作業文字列, "</i>", "")
      作業文字列 = Replace(作業文字列, "<p>", "")
      作業文字列 = Replace(作業文字列, "<ins class=""correction"" title=""text has unneeded close quote"">", "")
      作業文字列 = Replace(作業文字列, " </ins>", "")
      
      If InStr(入力英文行, "CHAPTER I") > 0 Then
         本文 = "本文"
      End If
      
'      Stop
      If 本文 = "本文" And Right(入力英文行, 4) = "</p>" Then
'      Stop
         If InStrRev(入力英文行, " ") > 0 Then
            英文行末語 = Mid(作業文字列, InStrRev(作業文字列, " ") + 1, Len(作業文字列) - InStrRev(作業文字列, " ") - 4)
         Else
            英文行末語 = Left(作業文字列, Len(作業文字列) - 4)
         End If
         
         If Len(英文行末語) > 0 Then
            Do
               検索数 = 検索数 + 1
               If 検索数 > 1900 Then
                  GoTo 検索終了
               End If
            Loop Until 英文行末語 = 対訳(検索数, 1)
            出力行 = Left(入力英文行, Len(入力英文行) - 4) & "<br>" & 対訳(検索数, 2) & "</p>"
             
         End If
'         Stop
      Else
検索終了:
      
         出力行 = 入力英文行

      End If
      出力ADODBストリーム.WriteText 出力行, 1    '//0:改行無し 1:改行有り

      出力行 = ""
        ' 最終行まで繰り返す
   Loop
        
   出力ADODBストリーム.SaveTofile (出力ファイル名), 2 'adSaveCreateOverWrite 上書きを許す
        
   ' 指定ファイルをCLOSE
   入力対訳ADODBストリーム.Close
   Set 入力対訳ADODBストリーム = Nothing
   入力英文ADODBストリーム.Close
   Set 入力英文ADODBストリーム = Nothing
   
   出力ADODBストリーム.Close
   Set 出力ADODBストリーム = Nothing

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

End Sub

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

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