VBAでテキストファイルのデータを読み込んでExcelで開く＋α

質問

テキストファイルをExcelファイルとして読み込む事が多く、その量に加えデータの並び方が特殊な為困っております。
テキストファイルのデータの並びをExcelで上下逆順に読み込ませるにはどのようにすればいいでしょうか？
また、まとめて複数のテキストファイルを上記の状態で自動的にシートごとに分けて出力させたりしたいのですが。

(例-１行目は無視)

---テキストデータ(タブ区切り)---
0　0
10　02　11
05　02　15
01　20　25
12　15　10

---Excelシートデータ---
0　0
12　15　10
01　20　25
05　02　15
10　02　11

回答No.8

BLUEPIXY

>マクロ実行時のSheet1のＡ１セルに書き出されてしまいます。
多分シートマクロにしているからだと思います。
ブックマクロにするか
標準モジュールにして実行すればいいんじゃないかと思います。

＞文字列を数値に変換するのに今結構てこずってます。
他にも色々方法はあるかと思いますが、
範囲を選択して、ツールチップ（？）から数値に変換を選ぶのが一番簡単だと思います。

お礼

返答が大変遅れまして、申し訳ありませんでした。
標準モジュールにして実行することで正常に書き出し行われました。
プログラムの変更で数値変換できるよう頑張ってみます。
有難う御座いました！

回答No.7

noname#22222

s_husky です。

ライブラリは、VBエディターを起動し

１、[挿入]-[標準ライブラリ]で作成します。
2、生成された<Module1>に全てをコピーします。
※コピーは一度切りです。その後の、コピーは厳禁です。
３、＜Module1＞は、’FileSystem’ などとリネームします。
※これは、他のブックにもエクスポート・インポートして利用します。

’FileSystem’は、広域に通用する関数ですから、どのシートからも利用できます。
なお、’FileSystem’として完備するには、次の関数もコピーされるといいでしょう。

' -------------------------------------------------
'　ファイルサイズを取得する関数
' -------------------------------------------------
Public Function FileSize(ByVal FileName As String) As Variant
On Error GoTo Err_FileSize
　　Dim fso　　 As FileSystemObject
　　Dim fil　　 As File
　　Dim lngSize As Long

　　Set fso = New FileSystemObject
　　Set fil = fso.GetFile(FileName)
　　lngSize = fil.Size
Exit_FileSize:
　　FileSize = lngSize
　　Exit Function
Err_FileSize:
　　lngSize = -1
　　Resume Exit_FileSize
End Function

' -------------------------------------------------
'　指定のディレクトリのファイルリストを配列で返す関数
' -------------------------------------------------
Public Function GetFileList(ByVal strDir As String, _
　　　　　　　　　　　　　　ByRef strFileNames() As String, _
　　　　　　　　　　　　　　Optional strName As String = "*") As Integer
On Error GoTo Err_GetFileList
　　 Dim I　　　 As Integer
　　 Dim J　　　 As Integer
　　 Dim N　　　 As Integer
　　 Dim fso　　 As FileSystemObject
　　 Dim fol　　 As Folder
　　 Dim fil　　 As File
　　 Dim fils　　As Files

　　 Set fso = New FileSystemObject
　　 Set fol = fso.GetFolder(strDir)
　　 Set fils = fol.Files

　　 I = I - 1
　　 N = UBound(strFileNames())
　　 For Each fil In fils
　　　　 If fil.Name Like strName And fil.Attributes = Archive Then
　　　　　　 I = I + 1
　　　　　　 strFileNames(I) = fil.Name
　　　　 End If
　　　　 If I = N Then
　　　　　　 MsgBox N & " 件でファイル名の取得を中止します。(GetFileList)", vbExclamation, " 関数メッセージ"
　　　　 End If
　　 Next
　　 For J = I + 1 To N
　　　　 strFileNames(J) = Empty
　　 Next J
Exit_GetFileList:
　　 GetFileList = I
　　 Exit Function
Err_GetFileList:
　　 I = -1
　　 MsgBox Err.Description & "(GetFileList)", vbExclamation, " 関数エラーメッセージ"
　　 Resume Exit_GetFileList
End Function

' -------------------------------------------------
'　指定のファイルを単一の文字列で戻す関数
' -------------------------------------------------
Public Function FileReadAll(ByVal FileName As String) As String
On Error GoTo Err_FileReadAll
　　 Dim fso As FileSystemObject
　　 Dim fil As File
　　 Dim txs As TextStream

　　 Set fso = New FileSystemObject
　　 Set fil = fso.GetFile(FileName)
　　 Set txs = fil.OpenAsTextStream(ForReading, TristateUseDefault)
　　 FileReadAll = txs.ReadAll
Exit_FileReadAll:
　　 Exit Function
Err_FileReadAll:
　　 MsgBox Err.Description & "(FileReadAll)", vbExclamation, " 関数エラーメッセージ"
　　 Resume Exit_FileReadAll
End Function

' -------------------------------------------------
'　指定のフォルダが存在するか否かを真・偽で返す関数
' -------------------------------------------------
Public Function FolderExists(ByVal FolderName As String) As Boolean
　　Dim fso As FileSystemObject

　　Set fso = New FileSystemObject
　　FolderExists = fso.FolderExists(FolderName)
End Function

' -------------------------------------------------
'　指定のファイルを順次呼び込む関数
’
'　FileRead("Test.txt") ---１行目を返す。
'　FileRead("Test.txt") ---2行目を返す。
'　FileRead関数が実行される都度に次行を呼び込みます。
' -------------------------------------------------
Public Function FileRead(ByVal FileName As String) As String
On Error GoTo Err_FileRead
　　Static isOpen As Boolean
　　Static fso　　As FileSystemObject
　　Static fil　　As File
　　Static txs　　As TextStream

　　If Not isOpen Then
　　　　isOpen = True
　　　　Set fso = New FileSystemObject
　　　　Set fil = fso.GetFile(FileName)
　　　　Set txs = fil.OpenAsTextStream(ForReading, TristateUseDefault)
　　End If
　　FileRead = IIf(fil.Name = FileName, txs.ReadLine, "")
Exit_FileRead:
　　If Len(FileRead) = 0 Then
　　　　isOpen = False
　　　　Set txs = Nothing
　　　　Set fil = Nothing
　　　　Set fso = Nothing
　　End If
　　Exit Function
Err_FileRead:
　　Resume Exit_FileRead
End Function

補足

返答が大変遅くなり、申し訳ありませんでした。
丁寧にご回答頂いて本当に嬉しい限りなんですが...。
> 1、[挿入]-[標準ライブラリ]で作成します。
> 2、生成された<Module1>に全てをコピーします。
ANo.1とANo.4とご回答頂いた分のプログラム全てですか？
Private Sub CommandButton1_Click()
から解釈してANo.1の分のコードはシート記述の方だと思ってたんですが
。
結構こんがらがってよく分からなくなってます(-_-;)
> なお、’FileSystem’として完備するには、次の関数もコピーされるといいでしょう。
は、Module1＝FileSystem(リネーム後)にということですよね。

回答No.6

asobe

#2のasobeです。

(1)メニューバー → ツール → マクロ → VisualBasicEditor を選択。
VisualBasicEditor(以下、VBE)が立ち上がります

(2)VBEの メニューバー → 挿入 → 標準モジュール を選択。
新しいウィンドウが表示されるので、以下のコードをコピー&ペースト。

Public Sub ConvertText()
Dim fn As Integer
Dim i As Integer
Dim strLine() As String
Dim obj As New DataObject
Dim strOutPut As String
Dim FileName As String

'ファイルパスのセルを指定
FileName = Cells(1, 1).Value

strLine = Split(vbNullString)
fn = FreeFile
Open FileName For Input As #fn
Do While Not EOF(fn)
ReDim Preserve strLine(UBound(strLine) + 1)
Line Input #fn, strLine(UBound(strLine))
Loop
Close #fn
strOutPut = strLine(0) & vbCrLf
For i = UBound(strLine) To LBound(strLine) + 1 Step -1
strOutPut = strOutPut & strLine(i) & vbCrLf
Next i
obj.SetText strOutPut
obj.PutInClipboard
ActiveSheet.Paste
End Sub

(3)Excelのワークシートに戻り、セル"A1"に読み込みたい
テキストファイルのパスを記述。

(4)テキストファイルの内容を出力したいセルをクリックして選択。

(5)メニューバー → ツール → マクロ → マクロ を選択。
マクロというタイトルのダイアログが立ち上がります。

(6)「CovertText」を選択して、実行ボタンをクリック。

以上です。

貼り付けたコードの
> 'ファイルパスのセルを指定
> FileName = Cells(1, 1).Value
の部分を、変更するとファイルパスを記入する位置を変更できます。
Cells("行","列").Value という書式です。

固定でよければセルから読まなくても
FileName = "C:\Test.txt"
などとしても良いです。

これはあくまで、実行までの過程を記述しただけですので、
どうしてそうなるのかという説明は、省いています。
いろいろ調べてみてください。
分からないところは、質問していただければ、
出来る限りお答えします。

※もし、コードの
> Dim obj As New DataObject
の部分でエラーが発生した場合は、
VBEの メニューバー → ツール → 参照設定 を選択。
リストの中から、「Microsoft Forms X.X Object Library」に
チェックを入れ、OKしてください。

お礼

丁寧に教えて頂きありがとうございます。
プログラムを実行し確認できました。
>これはあくまで、実行までの過程を記述しただけですので、
>どうしてそうなるのかという説明は、省いています。
>いろいろ調べてみてください。
>分からないところは、質問していただければ、
>出来る限りお答えします
ありがとうございます。
自分で調べて理解する努力も必要なので頑張ってみます。

回答No.5

BLUEPIXY

>それ以前に実行方法を自分が把握出来ていません...
Call readFile("input1.txt")
のようにファイル名を指定してreadFileを呼び出すと、
起動したブックと同じフォルダにある指定したファイルを
ファイル名をシート名とし、Ａ１セルを先頭としてファイルを読込ます。
Public Sub fileInput()
の方は、マクロの実行から呼び出します。
実行時にファイル名の指定をさせたい場合は、
この部分で、ファイル名を指定させたり、リストを作ったりして、
実際に読み込むreadFile に名前を指定して呼び出します。

補足

アドバイスありがとうございます。
プログラムのやろうとしていることが何となくですが分かってきました。
ただ文字列を数値に変換するのに今結構てこずってます。
それと、
Sheets.Add　　（新しいシートを挿入）
ActiveSheet.Name = "シート名"　（挿入直後は新しいシートがアクティブになる）
ので読み込んだテキストファイルのファイル名シートにテキスト中のデータが上下反転した状態で書き出されると思うのですが、マクロ実行時のSheet1のＡ１セルに書き出されてしまいます。(ただ文字列状態ですが）
文字列状態で書き出すのが原因ならちょっとお手上げかもしれません。
ご助言頂けると幸いです。

回答No.4

noname#22222

s_husky です。

FileExists()
FileReadArray()
FileWrite()

などの関数がないのが原因です。

＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
　２ステップ、１ステップは質問者の好みです
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊

No2、3の回答ですと、１ステップでエクセルに反映できます。
ただ、ファイルを送出する場合にタブをカンマ(,)にして拡張子をCSVにすればExcelシートは出来上がります。
こうして、一つひとつ成功を確認するのも手かということです。

※様々なライブラリを充実させて安直なコードでVBAを書くのか、それともその都度に書くのかは選択によります。
※質問者の関心の方向性が不明なので諸関数を伏せて回答した次第です。

＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
　追加すべき関数
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊

Option Explicit

Public Function FileWrite(ByVal FileName As String, _
　　　　　　　　　　　　　ByVal Text As String) As Boolean
On Error GoTo Err_FileWrite
　　Dim fso As FileSystemObject
　　Dim txs As TextStream

　　Set fso = New FileSystemObject
　　Set txs = fso.CreateTextFile(FileName, True)
　　txs.Write Text
　　FileWrite = True
Exit_FileWrite:
　　Exit Function
Err_FileWrite:
　　MsgBox Err.Description & "(FileWrite)", vbExclamation, " 関数エラーメッセージ"
　　Resume Exit_FileWrite
End Function

Public Function FileReadArray(ByVal FileName As String) As String()
On Error GoTo Err_FileReadArray
　　 Dim fso　　　　As FileSystemObject
　　 Dim fil　　　　As File
　　 Dim txs　　　　As TextStream
　　 Dim strText　　As String
　　 Dim strTexts() As String

　　 Set fso = New FileSystemObject
　　 Set fil = fso.GetFile(FileName)
　　 Set txs = fil.OpenAsTextStream(ForReading, TristateUseDefault)
　　 strText = txs.ReadAll
　　 strTexts = Split(strText, Chr$(13) & Chr$(10))
Exit_FileReadArray:
　　 FileReadArray = strTexts()
　　 Exit Function
Err_FileReadArray:
　　 MsgBox Err.Description & "(FileReadArray)", vbExclamation, " 関数エラーメッセージ"
　　 strTexts() = Split("")
　　 Resume Exit_FileReadArray
End Function

Public Function FileExists(ByVal FileName As String) As Boolean
　　Dim fso As FileSystemObject

　　Set fso = New FileSystemObject
　　FileExists = fso.FileExists(FileName)
End Function

補足

>※様々なライブラリを充実させて安直なコードでVBAを書くのか、それともその都度に書くのかは選択によります。
>※質問者の関心の方向性が不明なので諸関数を伏せて回答した次第です。
最終的に同じ結果が求まるにしても、その過程には様々な方法があると思います。手探りではありますが、少しずつ勉強していく中でこのようなプログラムに触れるのは良い刺激になります。
(ただ今は分からない事だらけですが）
追加すべき関数ということで
FileExists()
FileReadArray()
FileWrite()
の３つの関数を以前のプログラムとどうくっつけるのでしょうか。
ご助言頂ければ幸いです m(_ _)m

回答No.3

BLUEPIXY

'試しに作ってみました。適当に変更して下さい
'文字列で読み込んでいるので、数値にする場合は、・・
'---------------------------------------------------------------
Public Sub readFile(filename As String)
Dim path As String, data As String
Dim fso As Object, fi As Object
Dim separator As String
Dim a As Variant, b As Variant
Dim i As Long, MaxRow As Long

separator = vbTab 'タブ区切り
path = ActiveWorkbook.path '起動ディレクトリ
ActiveWorkbook.Sheets.Add '新しいシートを用意する
ActiveSheet.Name = filename '既にファイルが有る場合エラー！！
Set fso = CreateObject("Scripting.FileSystemObject")
Set fi = fso.OpenTextFile(path & "\" & filename)
data = fi.ReadLine '一行読込
a = Split(data, separator)
Range("A1").Resize(, UBound(a) + 1) = a
data = fi.ReadAll
b = Split(data, vbCrLf)
MaxRow = UBound(b) - 1 '最後の改行によるデータ分を－１する、改行で終わらない場合は補正不要
For i = 0 To MaxRow
a = Split(b(MaxRow - i), separator) '逆順にセット
Range("A2").Offset(i).Resize(, UBound(a) + 1) = a
Next

fi.Close
Set fi = Nothing
Set fso = Nothing

End Sub
Public Sub fileInput()
'ファイルがたくさんある場合は、リストを作ってループ
Call readFile("input1.txt")
End Sub

補足

ご回答ありがとうございます。
それ以前に実行方法を自分が把握出来ていません...

回答No.2

asobe

#1のような方法もあると思いますが、
わざわざファイルを作らなくても良いと思います。
テキストファイルから1行ずつ読込み、
アクティブセルに貼り付けています。

Private Sub ConvertText(ByVal FileName As String)
Dim fn As Integer
Dim i As Integer
Dim strLine() As String
Dim obj As New DataObject
Dim strOutPut As String

strLine = Split(vbNullString)
fn = FreeFile
Open FileName For Input As #fn
Do While Not EOF(fn)
ReDim Preserve strLine(UBound(strLine) + 1)
Line Input #fn, strLine(UBound(strLine))
Loop
Close #fn
strOutPut = strLine(0) & vbCrLf
For i = UBound(strLine) To LBound(strLine) + 1 Step -1
strOutPut = strOutPut & strLine(i) & vbCrLf
Next i
obj.SetText strOutPut
obj.PutInClipboard
ActiveSheet.Paste
End Sub

補足

ご回答ありがとうございます。
自分の希望とする結果が得られるような気がするのですが、
実行方法が分かりません。
ど素人でホントすみません。

回答No.1

noname#22222

ファイルそのものの並びを入れ替えればOKかと...

aaaaaaaa
BBBBBB
cccccccc
ddddddd
eeeeeeee
ffffffffffffffff

のような Text.txt を

aaaaaaaa
ffffffffffffffff
eeeeeeee
ddddddd
cccccccc
BBBBBB

に並び替えTest_II.txt で保存するには、

Option Explicit

Private Sub CommandButton1_Click()
　　Dim isOK As Boolean

　　isOK = ChangeFile("D:\Temp\Test.txt", "D:\Temp\Test_II.txt")
　　If Not isOK Then
　　　　MsgBox "該当するファイルが見つかりませんでした。"
　　End If
End Sub

Public Function ChangeFile(ByVal filName_Now As String, _
　　　　　　　　　　　　　 ByVal filName_New As String) As Boolean
　　Dim I　　　　　 As Integer
　　Dim J　　　　　 As Integer
　　Dim R　　　　　 As Integer
　　Dim strDatas()　As String
　　Dim strData　　 As String
　　Dim strNewDatas As String

　　If FileExists(filName_Now) Then
　　　　strDatas() = FileReadArray(filName_Now)
　　　　R = UBound(strDatas())
　　　　For I = 1 To R
　　　　　　If I > R - I + 1 Then
　　　　　　　　Exit For
　　　　　　Else
　　　　　　　　strData = strDatas(I)
　　　　　　　　strDatas(I) = strDatas(R - I + 1)
　　　　　　　　strDatas(R - I + 1) = strData
　　　　　　End If
　　　　Next I
　　　　strNewDatas = Join(strDatas(), Chr$(13) & Chr$(10))
　　　　If FileExists(filName_New) Then
　　　　　　Kill filName_New
　　　　End If
　　　　FileWrite filName_New, strNewDatas
　　　　ChangeFile = True
　　End If
End Function

などのコードを書くと実現できます。

※こんなんでよかったら、

FileExists()
FileReadArray()
FileWrite()

の関数の全容を追加回答します。

補足

迅速な対応ありがとうございます。
当方ど素人な為、プログラム見ても全然分からない関数ばかりです...
とりあえず、Excelシートにボタンを作ってコードそのままコピーで
実行させたんですが、コンパイルエラーが出て...
FileExistsのFunction定義ができてませんとかで怒られました。
そもそものやり方間違ってるのならごめんなさい。