Excel VBA ファイル操作
UNICODE でテキスト保存
海外から、Excelで、毎月、売り上げのトランザクション・ファイルが送られてきます。
これを、期末に、自動で集計するためのマクロを作りました。
テキスト保存する形式を、ShiftJIS、Unicode(UTF16)、UTF-8 から選択できるところが売りです。
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
Open メソッドを使って、Record または URL から Stream を開きます。
Close メソッドを使って、Stream を閉じます。
Write メソッドまたは WriteText メソッドを使って、バイトまたはテキストを Stream に入力 します。
ファイルに出力するのではない点に注意 。
Read メソッドまたは ReadText メソッドを使って、Stream からバイトを読み取ります。
ReadText メソッドは、文字列型ストリーム (Type が adTypeText) で使います。
バイナリ型のストリーム (Type が adTypeBinary) の場合は、Read を使います。
StreamReadEnum により、Stream オブジェクトから、ストリーム全体、または次の行を読み取るかどうかを指定します。
StreamReadEnum 定数 StreamReadEnum 値 説明
adReadAll -1 既定値です。現在の位置から EOS マーカー方向に、すべてのバイトをストリームから読み取ります。
これは、バイナリ ストリームに唯一有効な StreamReadEnum 値です (Type は adTypeBinary )。
adReadLine -2 ストリームから次の行を読み取ります (★ LineSeparator プロパティで指定 ★ )。
Flush メソッドを使って、ADO バッファにある Stream データを基になるオブジェクトに書き込みます。
CopyTo メソッドを使って、Stream の内容を別の Stream にコピーします。
SkipLine メソッドおよび LineSeparator プロパティを使って、ソース ファイルから行を読み取る方法を制御します。
LineSeparator プロパティ は、テキスト Stream オブジェクトの行区切り文字として使用する改行コード を指定します。
値の取得も可能です。既定は adCRLF です。
-1:adCRLF:CRLF (Windows)
10:adLF:LF (Unix) ←明示的に指定する必要が有ります。
13:adCR:CR
EOS プロパティおよび SetEOS メソッドを使って、ストリーム位置の末尾を設定します。
SaveToFile メソッドおよび LoadFromFile メソッドを使って、ファイル内のデータを保存および復元します 。
Stream オブジェクトからファイルを保存するときに、SaveOptionsEnum を使って、ファイルを作成するか、上書きするかを表します。これらの値は AND 演算子で結合することができます。
SaveOptionsEnum 定数 SaveOptionsEnum 値 説明
adSaveCreateNotExist 1 既定値です。FileName パラメータで指定したファイルがない場合は新しいファイルが作成されます。 adSaveCreateOverWrite 2 FileName パラメータで指定したファイルがある場合は、現在開かれている Stream オブジェクトのデータでファイルが上書きされます。
Charset プロパティを使って、Stream の保存に使う文字セットを指定します。
Cancel メソッドを使って、非同期 Stream 操作を停止します。
Size プロパティを使って、Stream 内のバイト数を設定します。
Position プロパティを使って、Stream 内の現在の位置を制御します。
Type プロパティを使って、Stream 内のデータ型を設定します。
State プロパティを使って、Stream の現在の状態 (開いている、閉じている、または実行中) を設定します。
Mode プロパティを使って、Stream のアクセス モードを指定します。
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 の位置を越える書き込みを行うと、
Stream の
Size は、新しく書き込まれた文字がすべて格納されるように拡張され、
EOS は、
Stream に新しく書き込まれた最後の文字に移動します。
注意 WriteText メソッドは、文字列型ストリーム (Type が adTypeText ) で使用します。バイナリ型のストリーム (Type が adTypeBinary ) には、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 に渡して、辞書データに変換します。
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 の内容は下記のようになっています。
おお‐おく 【大奥】〔おほ‐〕 1 江戸城内で、将軍の御台所(みだいどころ) (正妻)や側室が居住した所。将軍を除き、男子禁制。 2 貴人の奥方の居所。また、その奥方。
html はファイル中に改行コードが入っていないので、まずテキスト・エディタで項目の区切り(<a ></a> の直前)に改行コード(CRLF)を入れた後、下記のマクロで順を追って加工していきます。
1.単語と説明に分けて必要部分を抽出して StarDict 1行テキストに変換する。
これを StarDict Editor に掛けると、行データの重複のエラーが検出されてコンパイルできませんでした。
このため、重複行を削除するために下記のマクロを作りました。
2.テキスト・ファイルをソートする。
3.ソートされたファイルから重複行を削除して書き出す。
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"> </a> の形式を前もって削除。悪事を働く者の仲間
入力行 = 正規表現で置換 (入力行, "<a name=""[0-9]{10}""> </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(訳語部分, " ", " ") ' を削除
' 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(単語, " ", " ") '<a name="0030332276"> </a>部分を削除
単語 = 正規表現で置換 (単語, "<(.*?)>", "") 'html タグを除去
単語 = Trim(単語)
訳語部分 = LTrim(Right(入力行, Len(入力行) - 単語部分文字目 - 3))
' Stop
If Left(訳語部分, 4) = "<br>" Then '単語の直後の"<br>"は除去
訳語部分 = Trim(Right(訳語部分, Len(訳語部分) - 4))
End If
訳語部分 = Replace(訳語部分, "<br>", "\n") '前もって改行タグを修正
訳語部分 = Replace(訳語部分, " ", "") ' を削除
' 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"> </a>部分を削除
入力行 = 正規表現で置換 (入力行, "<a name=""[0-9]{10}""> </a>", "")
If Left(入力行, 12) = "<a ></a> <b>" Then
単語部分文字目 = InStr(入力行, "</b>")
単語 = Mid(入力行, 13, 単語部分文字目 - 13)
単語 = 正規表現で置換 (単語, "<(.*?)>", "") 'html タグを除去
単語 = Replace(単語, " ", " ") ' を削除
単語 = Trim(単語)
訳語部分 = LTrim(Right(入力行, Len(入力行) - 単語部分文字目 - 3))
' Stop
If Left(訳語部分, 4) = "<br>" Then '単語の直後の"<br>"は除去
訳語部分 = Trim(Right(訳語部分, Len(訳語部分) - 4))
End If
訳語部分 = Replace(訳語部分, "<br>", "\n") '前もって改行タグを修正
訳語部分 = Replace(訳語部分, " ", "") ' を削除
' 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 の戻り値
string1 が string2 より小さい
-1
string1 が string2 と等しい
0
string1 が string2 より大きい
1
string1 または string2 が Null である
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
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 解析時にはこの不要なタブを除去して処理しています。
追記 :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