この記事は「Spreadsheets/Excel Advent Calendar 2019」の 7日目の記事です。

##使用方法
下記のスクリプトをShiftJISで保存して、開きたいCSVファイルをスクリプトにドロップすれば道は開かれます。

CsvImpExcel.vbs

Dim oArgs, oWSH, oFSO, oXLS, oWbk, oSht

Call Main

Sub Main
  Set oFSO = CreateObject("Scripting.FileSystemObject")
  Set oArgs = WScript.Arguments
  For i = 0 to oArgs.Count - 1
    Call CsvImpExcel(oArgs(i))
  Next
End Sub

Sub CsvImpExcel(argFileName)
'  MsgBox argFileName

  nCols = GetMaxCols(argFileName)
  'nCols = 26

  If nCols = 0 Then
    WScript.Echo "ファイルが空です：" & argFileName
    Exit Sub
  End If

  If IsEmpty(oXLS) Then
    Set oXLS = CreateObject("Excel.Application")
    oXLS.Visible = True
    oXLS.WindowState = -4137 'xlMaximized
    Set oWSH = CreateObject("WScript.Shell")
    oWSH.AppActivate oXLS.Caption
  End If

  oXLS.Workbooks.Add
  Set oWbk = oXLS.ActiveWorkbook
  Set oSht = oWbk.ActiveSheet
  With oSht.QueryTables.Add("TEXT;" & argFileName, oSht.Range("$A$1"))
    '.CommandType = 0
    '.Name = "sample"
    '.FieldNames = True
    '.RowNumbers = False
    '.FillAdjacentFormulas = False
    '.PreserveFormatting = True
    '.RefreshOnFileOpen = False
    '.RefreshStyle = 1 'xlInsertDeleteCells
    '.RefreshPeriod = 0
    '.TextFilePromptOnRefresh = False
    '.SavePassword = False
    '.SaveData = True
    
    .TextFilePlatform = 932
    .TextFileStartRow = 1
    .TextFileTextQualifier = 1 'xlTextQualifierDoubleQuote
    .TextFileTrailingMinusNumbers = True
    .AdjustColumnWidth = True
    
    .TextFileParseType = 1 'xlDelimited
    .TextFileCommaDelimiter = True
    .TextFileTabDelimiter = True
    .TextFileSemicolonDelimiter = False
    .TextFileSpaceDelimiter = False
    .TextFileConsecutiveDelimiter = False
    '.TextFileOtherDelimiter = ":"

    Redim arCDTs(nCols - 1)
    For i = 0 To ubound(arCDTs)
      arCDTs(i) = 2
    Next
    
    '.TextFileParseType = 2 'xlFixedWidth
    '.TextFileFixedColumnWidths = Array(1, 1, 1)
    
    '.TextFileColumnDataTypes = Array(2, 2, 2)
    .TextFileColumnDataTypes = arCDTs
    
    .Refresh
    .Delete
    
  End With
  oWbk.Saved = True
End Sub

Function GetMaxCols(argFileName)
  '最終行、中間行の取得
  Set oCsv = oFSO.OpenTextFile(argFileName, 8) 'Append
  nLastLine = oCsv.Line
  oCsv.Close
  nHalfLine = nLastLine \ 2

  '最大列数の取得
  Set oCsv = oFSO.OpenTextFile(argFileName)
  If Not oCsv.AtEndOfLine Then
    '先頭行
    nMaxCols = ubound(Split(oCsv.ReadLine,",")) + 1
    '中間行
    For i = 2 To nHalfLine - 1
      oCsv.SkipLine
      n = n + 1
    Next
    If Not oCsv.AtEndOfLine Then
      nTmpCols = ubound(Split(oCsv.ReadLine,",")) + 1
      n = n + 1
      If nMaxCols < nTmpCols Then
        nMaxCols = nTmpCols
      End If
    End If
    '最終行-1
    For i = nHalfLine + 1 To nLastLine - 2
      oCsv.SkipLine
      n = n + 1
    Next
    If Not oCsv.AtEndOfLine Then
      nTmpCols = ubound(Split(oCsv.ReadLine,",")) + 1
      n = n + 1
      If nMaxCols < nTmpCols Then
        nMaxCols = nTmpCols
      End If
    End If
    '最終行
    If Not oCsv.AtEndOfLine Then
      nTmpCols = ubound(Split(oCsv.ReadLine,",")) + 1
      If nMaxCols < nTmpCols Then
        nMaxCols = nTmpCols
      End If
    End If
    'MsgBox nMaxCols
    GetMaxCols = nMaxCols
  Else
    GetMaxCols = 0
  End If
End Function

##解説など
Excelで表示形式を指定してCSVファイルを開く方法として、テキストファイルのインポートや区切り位置の指定がありますが、どちらもウィザード画面が出てきて、しかも列ごとに表示形式を設定しないといけないので、1回きりだけとかならいいけどまあ毎回やる気は起りません。

ならばとVBAで1行ずつ読んで各行各セルにセットするなどしてみると、ファイルサイズの小さいものなら早いのですが、10MB超えのファイルなどになると読み込み中で固まってしまって、待てども暮らせどもファイルは開きません。¹

じゃあどうするかというと、VBAを使うのですが取り込む方法は最初の方のテキストファイルをインポートする折衷案で、表示形式は全列に文字列形式をコードで設定する様にしています。ただこの方法ですとExcelで開く前にCSVファイルの列数が分かっていないとダメなので FileSystemObjectで先頭行/中間行/最終行を読んで、最大の列数をCSVファイルの列数としています。

このスクリプト自体は結構前に作って使っていたのですが、今年の夏頃にこの列数取得部分を追加したのでお薦めしてみても良いかなと思った次第です。²

障害対応中などの鉄火場ではそれは許されないのです。 ↩
今見返すと引用符を考慮した列数計算をして無いので、必要になったらそれも入れるかも ↩