VBA テキストtxtからエクセルexcelに張り付ける汎用ツール

はじめに

業務の中で、プログラム出力のテキストを、エクセルに張り付けて図表にする作業が多い。
これまで、できるだけ簡単に張り付けられるよう、出力形式を工夫していた。
しかし、年度末には、あまりに大量の処理が必要になった。
以前は、ruby-WIN32OLEを使ったりしたが、いろいろ制限もあるため、
VBAで、汎用ツールを作ることにした。

ツールの作成方針

①一つのセルに、処理定義(読み取りデータ、範囲、貼り付け先のシート、位置等をまとめて記述する。)
②処理定義の範囲を選択して、実行することで、まとめて複数の処理ができる。

ツールの効果

手前味噌ではあるが、これはよい。
なぜ、今まで作ってこなかったのだろうか？
今までの何十・何百時間が無駄だった・・・
理由は簡単で、VBAの知識が乏しく、汎用ツールを作る技術を持ち合わせていなかった。

VBAコード

Sub file_copy_paste()
'選択範囲のセル記載のコピー元情報(ファイル名/シート名,始点行,列,行,列数),
'  　　貼付先(シート名,行,列,種別(0:all,1:val),行列入替(0:off,1:on) ) でコピー・貼付
' 末尾の種別と行列入替は、省略可
' 貼付先が同一シートなら、空文字で、貼付先行列は、+,-を付けると相対位置で

    Set abook = ActiveWorkbook
    apath = ActiveWorkbook.FullName
    adir = Mid(apath, 1, Len(apath) - Len(abook.Name) - 1)
    For Each C In Selection
    '==========コピー元・先情報の整理
    '    MsgBox (c.Text)
        Set to0range = Cells(C.Row, C.Column) '貼り付けの基準とする
        infos = Split(C.Text, ",")
        fpath = infos(0) 'ファイル名;シート名 テキストならファイル名のみ、
        '\等のパスが入っていれば、開いていないファイルを開く。
        f_len = Len(fpath)
        If InStr(fpath, "/") > 0 Then
          booksheet = Split(fpath, "/")
          fbookp_s = booksheet(0): fsheet = booksheet(1)
        Else
          sfx = Mid(fpath, f_len - 3, 4)
          If sfx = ".txt" Or sfx = ".csv" Then '別テキスト
            fbookp_s = fpath:        fsheet = ""
          Else '同ファイル別シート
            fbookp_s = apath:        fsheet = fpath
          End If
        End If
        If InStr(fbookp_s, "\") > 0 Then
          dir_file = Split(fbookp_s, "\")
          If InStr(fbookp_s, ".") = 1 Then fbookp_s = adir & "\" & fbookp_s
          ffile = dir_file(LBound(dir_file))
        Else
          ffile = fbookp_s
        End If
        fi = CInt(infos(1)):    fj = CInt(infos(2)) 'コピー元始点の行列
        fni = CInt(infos(3)):   fnj = CInt(infos(4)) '0の時は、連続する末尾まで
         '============コピー先の分析
        tpath = infos(5)
        If InStr(tpath, "/") Then
          booksheet = Split(tpath, "/")
          tbookn = booksheet(0): t_sht = booksheet(1)
          tbooks = Split(tbookn, "\")
          tbookf = tbooks(UBound(tbooks))
          Set tbook = Workbooks(tbookf)
        Else
          t_sht = tpath
          tbook = abook
        End If
        t_isr = infos(6):    t_jsr = infos(7) 'コピー先始点の位置
        t_ir = CInt(t_isr)
        If Left(t_isr, 1) = "+" Or Left(t_isr, 1) = "-" Then t_ir = t_ir + to0range.Row
        t_jr = CInt(t_jsr)
        If Left(t_jsr, 1) = "+" Or Left(t_jsr, 1) = "-" Then t_jr = t_jr + to0range.Column
        t_typ = 0   '貼り付けオプション 0:値、1:全部
        jtrans = False
        
        If UBound(infos) > 6 Then
          t_typ = CInt(infos(8))
          If t_typ = 0 Then paste_typ = xlPasteValues Else: paste_typ = xlPasteAll
        End If
        If UBound(infos) > 7 Then
          t_trans = infos(9)    '貼り付け行列入れ替え 1:transpose:=true,false
          If t_trans = 1 Then jtrans = True Else:    trans = False
        End If
    '============コピー元のオープン
        For Each book In Workbooks
          If book.Name = ffile Then flag = True
        Next
        If flag = True Then
          Set fbook = Workbooks(ffile)
        Else
          Set fbook = Workbooks.Open(fbookp_s)
        End If
        fbook.Activate
        If fsheet <> "" Then ActiveWorkbook.Sheets(fsheet).Activate
    '============コピー、貼り付け
        Set fstart = Cells(fi, fj)
        If fni = 0 Then fni = fstart.End(xlDown).Row - fi + 1
        If fnj = 0 Then fnj = fstart.End(xlToRight).Column - fj + 1
        Range(fstart, Cells(fi + fni - 1, fj + fnj - 1)).Copy
        
        tbook.Activate
        If t_sht <> "" Then
          jex = False
          For Each s_sht In ActiveWorkbook.Sheets
            If s_sht.Name = t_sht Then jex = True
          Next
          If jex = False Then ActiveWorkbook.Sheets.Add.Name = t_sht
          ActiveWorkbook.Sheets(t_sht).Activate
        End If
        Cells(t_ir, t_jr).PasteSpecial _
            Paste:=paste_typ, Operation:=xlNone, SkipBlanks:=False, Transpose:=jtrans
        Application.CutCopyMode = False
        fbook.Close 'SaveChanges:=False
    Next
End Sub

その逆　エクセル⇒テキスト

Sub put_sheet2file()
'選択範囲のセル記載のシート名,保存先ファイル名(csv or txt or txtUni)
' シート名省略(一文字目が",")すると、現シート
' 保存先を*.txtu でUnicode
    Set abook = ActiveWorkbook
    apath = ActiveWorkbook.FullName
    adir = Mid(apath, 1, Len(apath) - Len(abook.Name) - 1)
    asht = ActiveSheet.Name
    For Each C In Selection
    '==========コピー元シート名の処理
        infos = Split(C.Text, ",")
        f_sht = infos(0) 'シート名
        f_len = Len(f_sht)
        If f_len = 0 Then '同シート
            f_sht = asht
        End If
        t_file = infos(1)
        t_filel = Len(t_file)
        If Right(t_file, 4) = ".txt" Then
          ftyp = xlText
        ElseIf Right(t_file, 4) = ".csv" Then
          ftyp = xlCSV
        ElseIf Right(t_file, 5) = ".txtu" Then 'UTF-text
          ftyp = xlUnicodeText
          t_file = Left(t_file, t_filel - 1)
        Else
          MsgBox ("Erro ftype")
          Exit Sub
        End If
    '==========保存先ファイル名の処理
        If t_filel > 0 And InStr(fbookp_s, "\") > 0 And InStr(fbookp_s, ".") = 1 Then
          tpath = adir & "\" & t_file
        Else
          t_path = t_file
        End If
    '==========コピー・保存
        abook.Activate
        Sheets(f_sht).Select
        Sheets(f_sht).Copy
        ActiveWorkbook.SaveAs FileName:=tpath, FileFormat:=ftyp, CreateBackup:=False
        ActiveWorkbook.Close (False)
    Next
    abook.Sheets(asheet).Activate
End Sub