エクセルの各シートに複数のtxtファイルを取り込む

質問

Excel2013を用いたデータ整理をしているのですが，複数のファイルを扱う上でマクロを用いた効率化をしたいと思い，質問させていただきました．

いま，Folder1 というフォルダに，text1 から text40 までの 40個のtxtファイルがあります．
これらのファイルを，エクセル上であらかじめ作成してある Sheet1 から Sheet40 にそれぞれ貼り付けたいと考えています．

txtファイルは，4列で構成されており，タブでそれぞれ区切られています．
行数は20,481行です．
txtの中には，0 の値が入った箇所もあるため，その情報が消えないで貼り付けられると望ましいです．
また，タブのところでしっかり区切られ，違うセルに貼り付けられると，ありがたいです．

質問は以上です．
お手数ですが，よろしくお願いします．

回答No.5

tsubu-yuki · ベストアンサー

早い話、作ってくれという事ですよね(笑)。

他さまよりかなり単純ですが、充分動きます。
[保存場所]には、「folder1」がある場所を
１文字も漏らさずに指定してくださいね。

Sub Nantoka()
Dim TagSH As Worksheet, SHNo As String

　　Application.ScreenUpdating = False
　　Application.DisplayAlerts = False

　　For Each TagSH In Worksheets
　　　　SHNo = Mid(TagSH.Name, 6, 2)
　　　　Workbooks.OpenText Filename:="C:\[保存場所]\Folder1\text" & SHNo & ".txt", _
　　　　　　　　DataType:=xlDelimited, _
　　　　　　　　Tab:=True, _
　　　　　　　　FieldInfo:=Array(Array(1, 1), Array(2, 1), _
　　　　　　　　　　　　　Array(3, 1), Array(4, 1)), _
　　　　　　　　TrailingMinusNumbers:=True
　　　　Cells.Copy TagSH.Cells
　　　　ActiveWorkbook.Close savechanges:=False
　　Next

　　Application.DisplayAlerts = True
　　Application.ScreenUpdating = True
End sub

とりあえず・・２万行を行単位で書き写すより、
テキストファイルを開いて全部コピーして、
エクセルに貼り付けて、テキストファイルを閉じる、
を繰り返した方が早いよ、多分。
そのかわり、他の作業とか一切考えてないけれど。
質問文には「他の作業」について触れてないしＯＫでしょ。
という発想ですね。

パソコンの能力に依るかもしれませんが、
多分、数秒～数分で終わると思いますよ。
テキストファイル４０個なら多分・・３０秒くらいかなぁと思うのですが。
１０分待っても終わらなければ残念ながらフリーズしています。

お礼

ご回答ありがとうございます．
お陰様で行いたかった作業が実現しました．
誠にありがとうございました．

回答No.6

watabe007

Sub Test()
Dim myPath As String, i As Long

myPath = "C:\Folder1"
Application.ScreenUpdating = False
For i = 1 To 40
With Worksheets(i).QueryTables.Add(Connection:= _
"TEXT;" & myPath & "\text" & i & ".txt", Destination:=Worksheets(i).Range("A1"))
.TextFilePlatform = 932
.TextFileParseType = xlDelimited
.TextFileTabDelimiter = True
.Refresh
.Delete
End With
Next
Application.ScreenUpdating = True
MsgBox "取込み完了!!"
End Sub

お礼

ご回答ありがとうございます．
このマクロで行いたかった作業ができました．
ありがとうございました．
回答順から，申し訳ありませんがNo.5の方をベストアンサーとさせていただきました．

回答No.4

imogasi

実際のファイルでテストできないので、下記コードに不安はある。
ＷＥＢの記事の探し方や利用する考え方なりを参考にしてください。
よくあるパターンの質問だが、質問者には本質問は、荷が重いと思われる。
本当にまる写しのコードでないとダメなのかもしれないと思いつつ書いたが。
(1)準備
テキストファイルのある対象のフォルダのフルパス名を調べてメモする。
その中に対象外のテキストファイルがないことを確認する。
混じっていると、排除するコードは質問者には作れないだろうから、手動で
別フォルダに移す。
ーー
書き出すＥｘｃｅｌのブックのシートの数だけシートを作る方法。
そのブックを開いてＶＢＡで下記を実行。下記の３のところを必要数にする。
以下コードは、すべて標準モジュールにコードを作る。
Sub test01()
Sheets.Add Count:=3
End Sub
（２）そのフォルダのテキストファイル名を、シート院エクス番号iの１シートのＡ１セルに、
１テキストファイルの名前書き出す。ファイル名しか書き出ししないのは、準備テスト段階です。
Sub test03()
Dim strPath As String
strPath = ThisWorkbook.Path
MsgBox strPath
'FileSystemオブジェクト変数の準備
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject") 'FileSystemObject

Dim objFile As Object 'ファイルを格納するオブジェクト変数
i = 1
For Each objFile In objFSO.getfolder(strPath).Files
ex = objFSO.GetExtensionName(objFile)
MsgBox ex
If ex = "txt" Then
'MsgBox i
'MsgBox ex
'MsgBox objFile.Name
'---
With ThisWorkbook
With .Worksheets(i)
.Cells(1, "A") = objFile.Name

End With

End With
i = i + 1

End If
If i > 5 Then Exit Sub 'テストのためなので、５テキストに限って実行し、打ち切り。
Next objFile
End Sub
（３）テキストファイルの各レコードをエクセルシートに読み込み。
http://qiita.com/ktyubeshi/items/199fd3efcf48e67645f1
より拝借。
下記は、一部変えてます。
Sub ReadTabDelimitedTextFile()
'タブ区切りファイルを全て文字列として読み込む
１つのテキストファイル名をメモする。そのファイルでテストする。ーーー＞文字列Ｘとする

Dim FileName As String
Dim i As Long
Dim Cnt As Long
Dim Buf As Variant
Dim FileNo As Integer
Dim SplitString As Variant

'ファイルダイアログを表示
'FileName = Application.GetOpenFilename("テキストファイル,*.txt")
　　FileName = Application.GetOpenFilename("テキストファイル,X.txt") <--ここを現実のものに変える
If FileName <> "False" Then

'全セル選択して書式を文字列にセットする
Cells.Select
Selection.NumberFormatLocal = "@"
Cells(1, 1).Select

'空いているファイル番号を取得
FileNo = FreeFile()
Buf = Space(FileLen(FileName))

'ファイルを開いてbufに1行読み込み
' → タブで配列に分割
' → セルに書き出し
Open FileName For Input As #FileNo
Do Until EOF(FileNo)
Line Input #FileNo, Buf
Cnt = Cnt + 1
SplitString = Split(Buf, vbTab)
For i = 0 To UBound(SplitString)
Cells(Cnt, i + 1) = SplitString(i)
Next i
Loop

Close #FileNo

'そのままでは数式等が使えなくなるため、書式を標準に戻す
Cells.Select
Selection.NumberFormatLocal = "G/標準"
Cells(1, 1).Select

Else
'ファイルダイアログをキャンセルされた場合何もしない
End If
End Sub
（４）プログラムが止まらずに、うまく行って、シートを見て、内容的にＯＫなら、上記のコードを（３）の
.Cells(1, "A") = objFile.Name
の部分に上書き張り付ける。
そして（３）の
fileName = Application.GetOpenFilename("テキストファイル,X.txt") <--ここを現実のものに変える
のＸの部分を、（２）のobjFile.Nameに変える。
FileName = Application.GetOpenFilename("テキストファイル,objFile.name & " .txt")　のように。
また、(2)でif i > 5 Then Exit Sub の部分は、テストのためなので、この行は、削除する。
（５）実行
シートについて内容を確認する。

お礼

ご回答ありがとうございます．
プログラムに細かい説明も添えていただき，素人の身としては助かりました．
ありがとうございました．

回答No.3

emsuja

2 です、補足拝見しました

Sub Main の最初に
Application.ScreenUpdating = False
最後に
Application.ScreenUpdating = True
を入れると、動作中に画面の表示動作を停止させますので多少は早くなるのでは？

回答No.2

emsuja

#1 です
前回の私のアドバイスが勘違いしてたかもしれません
相変わらず泥臭い書き方ですが新たに書き直してみました

Option Explicit
Dim fn As String, sn As String
Sub Main()
Dim pn As String, n As Integer, rtn As Integer
pn = "f:\test\" text ファイルのフォルダ名
For n = 1 To 40
fn = pn & "text" & n & ".txt"
If ExistFile(fn) Then ' ファイルの存在チェック
sn = "Sheet" & n
If ExistSheet(sn) Then ' Worksheet の存在チェック
Call test2
Else
rtn = MsgBox("WorkSheet " & sn & " が見当たりませんキャンセルしますか?", vbYesNo)
If rtn = vbYes Then Exit For
End If
Else
rtn = MsgBox("入力ファイル " & fn & " が見当たりませんキャンセルしますか?", vbYesNo)
If rtn = vbYes Then Exit For
End If
Next n
MsgBox "処理終了"

End Sub

Sub test2()
Dim f As Integer, w As String, d() As String, r As Long, c As Integer
With Worksheets(sn)
f = FreeFile
Open fn For Input As f
Do Until EOF(f)
Line Input #(f), w
d() = Split(w, vbTab)
r = r + 1
For c = 0 To UBound(d)
.Cells(r, c + 1).Value = d(c)
Next
Loop
Close f
End With
End Sub
'-----------------------------------------------------
' ファイルのの存在チェック
Function ExistFile(fn As String) As Integer
Dim f As Integer
On Error Resume Next
f = FreeFile()
Open fn For Input As f
Close f
If Err Then
ExistFile = False
Else
ExistFile = True
End If
On Error GoTo 0
End Function
' ----------------------------------------------------
' ワークシートの存在チェック
Function ExistSheet(sn As String) As Integer
Dim x As Object
ExistSheet = False
For Each x In Worksheets
If UCase$(x.Name) = UCase$(sn) Then
ExistSheet = True
Exit For
End If
Next
End Function

補足

ご回答ありがとうございます．
早速試したところ，実行は正常にされました．
ですが，各ファイルの容量が大きいせいか，1シート辺り3分程度と処理に相当な時間がかかってしまっています．
クォリティが落ちてもかまいませんので，処理速度を速めるのにどこか改良できる箇所があれば，ご教示願います．
無理を言って申し訳ありませんが，よろしくお願い致します．

回答No.1

emsuja

これで解決できなかったのですか？
解決できなかったのならその問題点を書いた方がいいアドバイスが付くと思いますが・・・
https://okwave.jp/qa/q9368534.html
そのあたりを明確にしないと同じようなアドバイスしかつかないと思います

補足

ご回答ありがとうございます．
以前の問題はお陰様で解決いたしました．
今回，行っている作業プロセスの微妙な変更がありまして，そうすると前回教えていただいたマクロは使用できなかったため，再び質問をさせていただきました．
下手な書き方をしてしまい申し訳ないのですが，テキストの読み込みの際に，今回は新しいシートを作りそこにテキストファイルを貼り付けていくのではなく，あらかじめ作ってある複数のシートにテキストファイルを貼り付けていく，という違いがあります．
これを可能とするマクロをぜひ教えていただきたいです．
よろしくお願い致します．
このあたりを明確にせずに質問してしまい，申し訳ありませんでした．