エクセルのテキスト貼り付けマクロ

テキストのテストエビデンスなどをパソコンではオフィスなどしか触ったことのない人に見せる場合、エクセルに貼り付けて送付したりするという事がよくあった。大量にある場合はエクセルの得意な方に、テキストをシートに貼り付けるマクロを書いてもらって対処したりしていたが、環境が変わるたびに作ってもらえる人を探すのも不毛なので自分で作ってみることにした。

unix 側で取得したテキストエビデンスをPCに移動し、そのエビデンスのフォルダにマクロを仕掛けたエクセルファイルを放り込んでマクロを起動すると、全テキストファイルをファイル毎に１シートにして一つのブックにするものである。

今回は、java のソースのsdiff の結果を sjis にコード変換したのちタブをスペースに置き換えて利用した。

$ sdiff test01.java test02.java | nkf -s | expand -8 > ../excel/test01-02.txt
$ sdiff test02.java test03.java | nkf -s | expand -8 > ../excel/test02-03.txt
$ sdiff test03.java test04.java | nkf -s | expand -8 > ../excel/test03-04.txt

マクロを起動結果。


ソースコード

Sub Macro1()
    Dim myPath As String
    Dim myFileName As String
   
    '新規ブックの作成
    Dim myWb As Workbook
    Set myWb = Workbooks.Add
  
    '指定ディレクトリのファイルを順番にシートに貼り付け
    myPath = ThisWorkbook.Path & "\"
    myFileName = Dir(myPath, 0)
    Do While Len(myFileName) > 0
        ' テキストファイルの場合シート作成
        If Right(myFileName, 3) = "txt" Then
            MakeSheet file:=myFileName, sheet:=myWb
        End If
        Debug.Print myPath & myFileName
        myFileName = Dir()
    Loop
End Sub

Sub MakeSheet(file As String, sheet As Workbook)
    Dim myFso As Object
    Dim myFileName As String
    Dim myStr As String
    Dim cnt As Long
    Dim mySht As Worksheet
    Set myFso = CreateObject("Scripting.FileSystemObject")
    '
    ' 新しいシートを追加
    Set mySht = Worksheets.Add(after:=Sheets(Sheets.Count))
    mySht.Name = file
    
    'シート全体を選択してフォントを設定
    Cells.Select
    mySht.Cells.Font.Size = 10
    mySht.Cells.Font.Name = "HGｺﾞｼｯｸM"
    
    '罫線を削除
    Cells.Select
    ActiveWindow.DisplayGridlines = False
    
    'ファイル名を設定
    myFileName = ThisWorkbook.Path & "\" & file
    
    '一行ずつ読み込み、シートに文字列として貼り付け
    cnt = 1
    With myFso.OpenTextFile(myFileName, 1)
        Do Until .AtEndOfStream
            myStr = .ReadLine
            Debug.Print myStr
            With Cells(cnt, 1)
                .NumberFormatLocal = "@"
                .Value = myStr
            End With
            cnt = cnt + 1
        Loop
        .Close
    End With
    
    ' ワークシートを指定ブックに移動
    mySht.Move before:=sheet.Sheets(1)
    
    Set mytxt = Nothing
    Set myFso = Nothing
    Set mySht = Nothing
End Sub