VBA tsvファイル 読み書き

ファイル形式：tsv
文字コード:UTF-8
改行コード:LF

Option Explicit
Function readTsv()
'tsv読み込み処理を行う
    Dim targetFilePath As String
    Dim readTxt As String
    Dim maxCol As Long, maxRow As Long
    Dim splitList_row As Variant, splitList_col As Variant
    
    targetFilePath = openFileDialog
    
    'tsv読み込み
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile targetFilePath
        readTxt = .ReadText
        .Close
    End With
        
    splitList_row = Split(readTxt, vbLf)
    
    '行、列の最大数（0始まりのため1足す）
    maxRow = UBound(splitList_row) + 1
    maxCol = UBound(Split(splitList_row(0), vbTab)) + 1
        
    Dim i
    For i = 1 To maxRow
        splitList_col = Split(splitList_row(i - 1), vbTab) 'リストの先頭0の為-1する
        '1行ずつデータをセルに代入
        Range(Cells(i, 1), Cells(i, maxCol)) = splitList_col
    Next i

End Function

Function openFileDialog() As String
'ファイルダイアログを開き、指定したファイルを返す
'return
'OpenFileDir:strng:指定したファイル名（指定しなかった場合は処理終了）


  Dim OpenFileDir As String 'オープンするFileのディレクトリ
  'デフォルトのパスをカレントディレクトリに変更
  ChDir ActiveWorkbook.path
  OpenFileDir = Application.GetOpenFilename("ファイル,*.tsv")
  If OpenFileDir = "False" Then End
  
  openFileDialog = OpenFileDir
End Function

Function createTsvFile()
'ファイルへ書き込む
 
   Dim adoObj As Variant
   Dim savefileDir As String
   savefileDir = openFolderPicker()
   
    Set adoObj = CreateObject("ADODB.Stream")
    With adoObj
        .Charset = "UTF-8"
        .Type = 2 'テキストモード
        .LineSeparator = 10 '改行コードLF
        .Open

        '文字列を行単位でストリームに書き込む
        Set adoObj = writeRowStr(adoObj)
        
        'ストリームに書き込んだ文字列をTSVファイルに保存する
        .SaveToFile savefileDir & "\test.tsv", 2
        .Close
    
    End With

End Function
Function writeRowStr(adoObj As Variant) As Variant
'文字列を行単位でストリームに書き込む
  Dim endRow As Long, endCol As Long, i, j
  Dim writeStrTmp As String
  
  endRow = Range("A" & Rows.Count).End(xlUp).Row
  endCol = Cells(1, Columns.Count).End(xlToLeft).Column
  For i = 1 To endRow
    
    writeStrTmp = "" '初期化
    For j = 1 To endCol
      
      If j = 1 Then
        writeStrTmp = Cells(i, j)
      Else
        writeStrTmp = writeStrTmp & vbTab & Cells(i, j)
      End If
      
    Next j
    '書き込み
    adoObj.WriteText writeStrTmp, 1
    
  Next i
  Set writeRowStr = adoObj

End Function

Function openFolderPicker() As String
'フォルダピッカーを開き、指定したフォルダのパスを返す
  Dim folderArray As FileDialog
  Application.FileDialog(msoFileDialogFolderPicker).Show
  Set folderArray = Application.FileDialog(msoFileDialogFolderPicker)
  
  '選択しなかった場合は処理を終了する
  If folderArray.SelectedItems.Count = 0 Then End

  openFolderPicker = folderArray.SelectedItems(1)
   
End Function