Office関連

指定したセル範囲をUTF-8やEUC-JP等のテキストファイルとして出力するExcelマクロ

ExcelファイルをUTF-8のテキストファイルで出力する必要があったので、Streamオブジェクトを使った簡単なマクロを作ってみました。

Option Explicit

Public Sub Sample()
  If LCase(TypeName(Application.Selection)) <> "range" Then Exit Sub
  '選択範囲を[UTF-8,タブ区切り,CRLF改行,ダブルクォーテーション囲み有]で[C:\Test\Test.csv]として出力
  RangeToText Application.Selection, "C:\Test\Test.csv", "utf-8"
  '選択範囲を[EUC-JP,カンマ区切り,LF改行,ダブルクォーテーション囲み無]で[C:\Test\Test2.csv]として出力
  RangeToText Application.Selection, "C:\Test\Test2.csv", "euc-jp", ",", 10, False
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Private Sub RangeToText(ByVal TargetRange As Excel.Range, _
                        ByVal FilePath As String, _
                        ByVal CharacterSet As String, _
                        Optional ByVal Separator As String = vbTab, _
                        Optional ByVal LnSeparator As Long = -1, _
                        Optional ByVal FlgQuotes As Boolean = True)
  '指定したセル範囲をテキストファイルとして出力
  '----------------------------------------
  'TargetRange:出力対象セル範囲
  'FilePath:出力先のフォルダパス
  'CharacterSet:文字セット(HKEY_CLASSES_ROOT\MIME\Database\Charset 参照)
  'Separator:区切り文字
  'LnSeparator:行区切り文字(adCR:13, adCRLF:-1, adLF:10)
  'FlgQuotes:["]で囲むかどうかを指定
  Dim str As String
  Dim i As Long, j As Long
  Const adTypeText = 2
  Const adWriteChar = 0
  Const adWriteLine = 1
  Const adSaveCreateOverWrite = 2
  
  On Error Resume Next
  With CreateObject("ADODB.Stream")
    .Type = adTypeText
    .Charset = CharacterSet
    .LineSeparator = LnSeparator
    .Open
    For i = 1 To TargetRange.Rows.Count
      For j = 1 To TargetRange.Columns.Count
        If j = 1 Then
          If FlgQuotes = True Then
            str = ChrW(&H22) & TargetRange(i, j) & ChrW(&H22)
          Else
            str = TargetRange(i, j)
          End If
        Else
          If FlgQuotes = True Then
            str = str & Separator & ChrW(&H22) & TargetRange(i, j).Value & ChrW(&H22)
          Else
            str = str & Separator & TargetRange(i, j).Value
          End If
        End If
      Next
      If i = TargetRange.Rows.Count Then
        .WriteText str, adWriteChar
      Else
        .WriteText str, adWriteLine
      End If
    Next
    .SaveToFile FilePath, adSaveCreateOverWrite
    .Close
  End With
  If Err.Number <> 0 Then
    MsgBox "Err:" & Err.Description, vbCritical + vbSystemModal
    Exit Sub
  End If
  On Error GoTo 0
End Sub

文字セットや区切り文字を引数にしているので、例えば、[LF区切りのダブルクォーテーション囲み無しEUC-JPテキスト]といったファイルも簡単に作成することができます。

2014年4月の人気記事前のページ

Chromeアプリ版Office Onlineを使ってみました。次のページ

関連記事

  1. Office アドイン

    [Office用アプリ]開発入門の記事を書かせていただきました。

    日経ソフトウエア 2014年3月号から連載の「Office用アプリ開発…

  2. Office関連

    [VBA]自動的にフォントサイズを調整する疑似テキストボックス

    前回と同様、環境依存つながりでmougの給湯室に書いたコードを載せてお…

  3. アイコン一覧

    Office 2013 アイコン一覧(U)

    ・Office 2013 アイコン一覧 NUM…

  4. Office関連

    ZIP形式で圧縮・解凍を行うVBAマクロ

    この記事のように、処理の中でZIP形式のファイルを扱うことはありました…

  5. Office関連

    Google TTSで文字列を読み上げるExcelアドイン

    前回の記事で書いたGoogle TTSで文字列を読み上げるマクロ(言語…

  6. Office関連

    選択中の表の行数を取得するWordマクロ

    「Word VBA 表 行数」といったキーワード検索でのアクセスがあり…

コメント

  1. この記事へのコメントはありません。

  1. この記事へのトラックバックはありません。

Time limit is exhausted. Please reload CAPTCHA.

Translate

Chinese (Simplified)Chinese (Traditional)EnglishFrenchGermanJapaneseKoreanRussianSpanish

最近の記事

アーカイブ

PAGE TOP