初めに
テキストファイルをExcelシート上に読み込むマクロ。
注意事項
- テキストファイル内にタブが存在する場合は空白に変換してから読み込む
ソースコード
ReadTextFile.bas
Option Explicit
Sub テキストファイル読込()
Dim FilePath
Dim ResultRange As Range
FilePath = Application.GetOpenFilename("Text File(*.txt),*.txt,All Files(*.*),*.*")
If FilePath = False Then
Exit Sub
End If
Set ResultRange = ReadTextFile(ActiveCell, CStr(FilePath), 4)
If Not ResultRange Is Nothing Then
Call ResultRange.Select
End If
End Sub
Private Function ReadTextFile(TargetCell As Range, FilePath As String, Optional TabSize As Long = 4) As Range
Dim fso As Object
Dim TextStream As Object
Dim Text As String
Dim TabPos As Long
Dim Cell As Range
Set Cell = TargetCell.Cells(1)
Set fso = CreateObject("Scripting.FileSystemObject")
Set TextStream = fso.OpenTextFile(FilePath, 1, False)
Do Until TextStream.AtEndOfStream
Text = TextStream.ReadLine
TabPos = InStr(Text, vbTab)
If TabPos > 0 Then
Text = TabToSpace(Text)
End If
If Left(Text, 1) = "'" Then
Text = "'" & Text
End If
Cell.NumberFormat = "@"
Cell.Value = Text
Set Cell = Cell.Offset(1, 0)
Loop
Call TextStream.Close
If TargetCell.Cells(1).Row = Cell.Row Then
Set ReadTextFile = Cell
Else
Set ReadTextFile = Application.Range(TargetCell.Cells(1), Cell)
End If
End Function
Private Function TabToSpace(Text As String, Optional TabSize As Long = 4) As String
Dim CurrPos As Long, PrevPos As Long, FindPos As Long
Dim SpcSize As Long, SubStr As String, Result As String
CurrPos = 0
PrevPos = 0
FindPos = InStr(PrevPos + 1, Text, vbTab)
Do While FindPos > 0
SubStr = Mid(Text, PrevPos + 1, FindPos - PrevPos - 1)
Result = Result & SubStr
CurrPos = CurrPos + LenB(StrConv(SubStr, vbFromUnicode))
SpcSize = TabSize - (CurrPos Mod TabSize)
Result = Result & Space(SpcSize)
CurrPos = CurrPos + SpcSize
PrevPos = FindPos
FindPos = InStr(PrevPos + 1, Text, vbTab)
Loop
If PrevPos = 0 Then
TabToSpace = Text
Else
TabToSpace = Result & Mid(Text, PrevPos + 1)
End If
End Function