こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

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

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

(例-1行目は無視)

---テキストデータ(タブ区切り)---
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

投稿日時 - 2006-03-14 08:31:33

QNo.2027817

困ってます

このQ&Aは役に立ちましたか?

2人が「このQ&Aが役に立った」と投票しています

回答(8)

ANo.8

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

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

投稿日時 - 2006-03-15 23:32:23

お礼

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

投稿日時 - 2006-03-30 14:07:59

ANo.7

s_husky です。

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

1、[挿入]-[標準ライブラリ]で作成します。
2、生成された<Module1>に全てをコピーします。
※コピーは一度切りです。その後の、コピーは厳禁です。
3、<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") ---1行目を返す。
' 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

投稿日時 - 2006-03-15 22:25:36

補足

返答が大変遅くなり、申し訳ありませんでした。
丁寧にご回答頂いて本当に嬉しい限りなんですが...。
> 1、[挿入]-[標準ライブラリ]で作成します。
> 2、生成された<Module1>に全てをコピーします。
ANo.1とANo.4とご回答頂いた分のプログラム全てですか?
Private Sub CommandButton1_Click()
から解釈してANo.1の分のコードはシート記述の方だと思ってたんですが

結構こんがらがってよく分からなくなってます(-_-;)
> なお、’FileSystem’として完備するには、次の関数もコピーされるといいでしょう。
は、Module1=FileSystem(リネーム後)にということですよね。

投稿日時 - 2006-03-30 14:08:56

ANo.6

#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してください。

投稿日時 - 2006-03-14 18:24:59

お礼

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

投稿日時 - 2006-03-15 22:11:19

ANo.5

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

投稿日時 - 2006-03-14 17:52:24

補足

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

投稿日時 - 2006-03-15 21:57:30

ANo.4

s_husky です。

FileExists()
FileReadArray()
FileWrite()

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

**********************
 2ステップ、1ステップは質問者の好みです
**********************

No2、3の回答ですと、1ステップでエクセルに反映できます。
ただ、ファイルを送出する場合にタブをカンマ(,)にして拡張子を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

投稿日時 - 2006-03-14 17:25:58

補足

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

投稿日時 - 2006-03-15 21:37:12

ANo.3

'試しに作ってみました。適当に変更して下さい
'文字列で読み込んでいるので、数値にする場合は、・・
'---------------------------------------------------------------
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 '最後の改行によるデータ分を-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

投稿日時 - 2006-03-14 14:25:04

補足

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

投稿日時 - 2006-03-14 17:16:20

ANo.2

#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

投稿日時 - 2006-03-14 13:13:11

補足

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

投稿日時 - 2006-03-14 16:45:22

ANo.1

ファイルそのものの並びを入れ替えれば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()

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

投稿日時 - 2006-03-14 09:36:18

補足

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

投稿日時 - 2006-03-14 16:22:40

あなたにオススメの質問