【VBA】エクセルファイルにtxtファイルのデータをコピペするコードについて

Question

エクセル2016を使っております。
Ｄドライブ直下のフォルダに、001、002というような数字の名称を付したエクセルファイルとテキストファイルがあります。（それぞれの名称のファイルが、エクセルファイルとテキストファイルの２つずつあります）

エクセルファイルを開き、マクロを実行すると、そのファイル名と同じ名称のテキストファイルのデータがそのエクセルファイルに貼り付けられるコードについてご教示願います。

よろしくお願いいたします。

WindFaller · Accepted Answer

遅くなってすみません。
テレビで、齋藤孝氏が「拙速は巧遅に勝る」とか言っていたのですが、ここの掲示板では、特にそれが求められるようで、気をつけたいのですが、なかなか思うに任せません。

>BaseName = Mid(ActiveWorkbook.Name, 1, InStrRev(ActiveWorkbook.Name, "."))
これでは、うまく行きませんね。私は、前言の說明で忘れていたようです。
Personal.xlsb の場合は、ちょっと特殊になってしまいます。そこにマクロが入っているわけですから、この段階で、どこの場所と明示されていません。省略すると、デフォルトの可能性が出てきてしまいます。(Application.DefaultFilePath) これは、アドイン型に直しても同様です。

デフォルトのファイルの置き場所にない以上、この場合は、ActiveWorkbook.Path の場所がどうしても入手しなくてはならなくなっています。

>エクセルファイルでは4行目から貼り付けたいと思っています。

Cells(i + 1, 1).Resize(, UBound(buf) + 1).Value = buf 'A1 から貼り付け
i + 1 =1行目 －> i + 4 =4行目
i というのは紛らわしいのですが、buf の配列変数にそれぞれの入れ物のindex の番号で 0から始まるように出来ています。

Sub GetSAmeNameTextOpenR()
  Dim BaseName As String
  Dim Fname As String
  Dim myPath As String
  Dim TextLine As String
  Dim i As Long, j As Long
  Dim ArLines
  Dim Fno As Integer
  Dim buf
  '***開始行**
  j = 5
  '*****
  myPath = ActiveWorkbook.Path & "\" 'パス
  BaseName = Mid(ActiveWorkbook.Name, 1, InStrRev(ActiveWorkbook.Name, "."))
  Fname = myPath & BaseName & "txt"
  If Dir(Fname) = "" Then _
　MsgBox Fname & "は、ここには見つかりません。", vbCritical: Exit Sub
  Fno = FreeFile()
  Open Fname For Input As #Fno
  Line Input #Fno, TextLine
  Close #Fno
  ArLines = Split(TextLine, vbLf)
  For i = 0 To UBound(ArLines) - 1
　buf = Split(ArLines(i), vbTab)
　Cells(i + j, 1).Resize(, UBound(buf) + 1).Value = buf 'Aj から貼り付け Cells(j, 1) Aj
  Next
End Sub

'//

以上ですが、私の今までの経緯からの予感では、この先、いろいろと難問が出てくるのではないかと思っています。

これは、SJIS ですが、UTF-8, UTF-16 の文字コードが変わった場合、または、文字コードの自動判別など、今回のLF 改行コードも、そのひとつです。一見簡単そうに思えても、Unicode ライクのテキストデータのCSV などは、滅多に出会わない種類のものです。

しかし、Excelでは、難しい内容ですも、Sakura Editor の他のテキスト・エディターに優れた機能には、どのエディターよりも豊富な正規表現や変換機能が使えるという利点を生かして、テキストファイルの加工が可能です。困った時には、このエディターで試してみると、思わぬ解決策が見つかることがあります。

WindFaller · Answer

>「Line Input #Fno, TextLine」の TextLineとはどういう意味ですか？
このTextLine という名称自体は特に何でもよいのです。別に決まりはありません。ただ、実際に、一行ずつ読み取っています。（先頭文字から[改行]までの１行) その改行自体が認識しないと、ひとつの切れ目のないテキストファイルになってしまいます。

その切れ目がないテキストファイルでも、Lf (文字コード:10) で区切って、行を作ってあげます。
ArLines = Split(TextLine, vbLf)

For i = 0 To UBound(ArLines) - 1（この行はなんとなくわかりますが）
×マイナス1にしているのは、0をスタートしているから、１引きました。
◎訂正します。ここは、－1をしなくても良かったでした。最後尾の文字が欠けたかもしれません。
　For i = 0 To UBound(ArLines)　'◎

buf = Split(ArLines(i), vbTab)
それで、今度は、実際の1行に、タブの入っているということで、タブで切り分けて、セルに横の方向に入れています。

kamonegi-order · Answer

簡単なコードなので、省きますが、
Txtのパスを指定して、連番ファイル名はループでファイル名をつくり、
ファイルを開き、内容を変数に格納、クローズでよいです。
Open Fname For Input As i
Line Input i, Tet
Close i

WindFaller · Answer

こんにちは。
>Personal.xlsbに
これ自体は、ThisWorkbook とあるところを、ActiveWorkbook にしていただければよいです。
置換機能を使って交換しても、手作業でもよいのですが、残さないようにしてください。

>myPath = ThisWorkbook.Path & "\" 'Excel と同じ場所にあるなら、ChDrive,ChDir は不要
これは、前回のコードをそのまま残しているだけです。
だから、インポートされる側のブックとテキストファイルが同じ場所にあるのなら、

'－－－MyPath は不要
BaseName = Mid(ActiveWorkbook.Name, 1, InStrRev(ActiveWorkbook.Name, "."))
Fname = BaseName & "txt" 'Excelと同じフォルダ等にする

ということになります。

------------
もう少し細かい說明が必要ですか？
つまり、Excelは、起動して、デフォルト・ファイルパスというフォルダを参照するように出来ています。(通常は、C:\Users\UserName\OneDrive\ドキュメント\ など)また、保存するフォルダも同じ場所にするように出来ています。

それを特殊な場所、例えば、C:\ などとする場合は、そのC:\ にExcelファイルがあれば、そのExcelファイルのある場所を参照するように、マクロで変えています。それを別な場所にファイルが置いてある場合は、デフォルトの参照フォルダーを変えてあげなくてはならないということです。
Chdrive =ドライブを変える、ChDir  =フォルダを変える

『Ｄドライブ直下のフォルダに、001、002というような数字の名称を付したエクセルファイルとテキストファイルがあります。』

ちょっと気を回しすぎかもしれませんが、往々にして、こういう原則というものは、忘れ去られてしまうことが多いのです。さて、実際にはどんなものかは、私は分からないのですが、素人マクロではない限りは、予想されるエラーや不具合は予め対応しておいても良いと思っているのでした。

WindFaller · Answer

こんばんは。

>改行コードは全てLEです。（サクラエディタで開くと「↓」です）
不具合は、了解しました。
LF のことですね。Line Feed の短縮系だったと思います。

当面のトラブルだけの問題解決になりますが、以下のようになります。

'//標準モジュール
Sub GetSAmeNameTextOpenR()
  Dim BaseName As String
  Dim Fname As String
  Dim myPath As String
  Dim TextLine As String
  Dim i As Long
  Dim ArLines
  Dim Fno As Integer　
  Dim buf
 
  myPath = ThisWorkbook.Path & "\" 'Excel と同じ場所にあるなら、ChDrive,ChDir は不要
  BaseName = Mid(ThisWorkbook.Name, 1, InStrRev(ThisWorkbook.Name, "."))
  Fname = myPath & BaseName & "txt" 'Excelと同じフォルダ等にする
  If Dir(Fname) = "" Then _
　MsgBox Fname & "は、ここには見つかりません。", vbCritical: Exit Sub

Fno = FreeFile()
  i = 1
  Open Fname For Input As #Fno
    Line Input #Fno, TextLine
  Close #Fno
  ArLines = Split(TextLine, vbLf)
  For i = 0 To UBound(ArLines) - 1
　buf = Split(ArLines(i), vbTab)
　Cells(i + 1, 1).Resize(, UBound(buf) + 1).Value = buf 'A1 から貼り付け
  Next
End Sub

WindFaller · Answer

まず、最初に、こちらが理解していないまま推し進めたのですから、いろんな問題は残っているはずです。

>テキストファイルが複数行に値が書いてある場合でも、それをエクセルファイルに貼り付けるとすべてが1行に収まって妙な形で貼り付けられてしまいます。

それは、予想だにしていませんでしたね。テキスト・ファイルなのに、そのような現象になるというのは、そのテキストファイルは、Windows/DOS系のものですか？

>拡張子は違いますが）のデータを貼り付けることはできました。

それで、文字化けのほうはしなかったのですね。しかし、拡張子が違うというのは、本当はテキストファイルではないかもしれません。テキストファイルだと思い込んでいるのに、実際は違う例が多々遭遇します。また、Mac系、Unix系のテキストファイルでも、そういう現象が起こります。

まず、そのファイルの末尾の改行コードは何か教えてください。おそらく、LF コードだと思いますが、いたるところに存在しているのですか、それとも、それがすべてなのですか？これは単なる確認事項ではあるけれども、それがすべてなら、Unix系のファイルだと思います。また、文字コードもついでに教えてください。

元は、データベースファイルのテキストファイル出力も同様ですが、拡張子が、.txt  ではないというのは、「トラブル発生の原因」になります。

WindFaller · Answer

こんにちは。

>データがそのエクセルファイルに貼り付けられるコードについてご教示願います。
そのままの通りのコードあるのですが、大掛かりになってしまいます。

現在の文字コードでは、S-JISになっていますから、これがUTF-8やUTF-16 の場合は、文字コードの変換を必要とします。Excelのシート自体は、UTF-16は対応しています。実にややこしい場合があります。（前回の質問からすると、可能性大です)

また、中身の文字コードも、指定されていれば問題は少ないのですが、UTF-16 Big Endian, Little Endian で、最初の信号がない場合に失敗する可能性が高いです。UTF-8には、そういう問題はありません。

失敗の場合（テキストファイルの文字コードが不明な場合)
「全体をコピーして、エクセルファイルに貼り付けると、」にしてほうが失敗は少ないですが、こちらにすると、試みた回数が少ないので、あまり自信がありません。

>Ｄドライブ直下のフォルダに
ルートのことでしょうか？

>それぞれの名称のファイルが、エクセルファイルとテキストファイルの２つずつあります
意味がよく分かりませんでしたので、同名のベースネーム（拡張子がない名前)を対象としました。

'//
Sub GetSAmeNameTextOpen()
  Dim BaseName As String
  Dim Fname As String
  Dim myPath As String
  Dim TextLine As String
  Dim i As Long
  Dim buf
　' ChDrive "D:\" 　'//ExcelとTextファイルと同じフォルダならいりません。
　 'ChDir "C:\Temp"  '// 直下のフォルダですと後は任意
　 
  myPath = ThisWorkbook.Path & "\"　'Excel と同じ場所にあるなら、ChDrive,ChDir は不要
  BaseName = Mid(ThisWorkbook.Name, 1, InStrRev(ThisWorkbook.Name, "."))
  Fname = myPath & BaseName & "txt"　'Excelと同じフォルダ等にする
 
  If Dir(Fname) = "" Then _
　MsgBox Fname & "は、ここには見つかりません。", vbCritical: Exit Sub
 
  FNo = FreeFile()
  i = 1
  Open Fname For Input As #FNo
  Do While Not EOF(FNo)
　Line Input #FNo, TextLine
　buf = Split(TextLine, vbTab)
　Cells(i, 1).Resize(, UBound(buf) + 1).Value = buf　'A1 から貼り付け
　i = i + 1
  Loop
  Close #FNo
End Sub

よろずやkinchan · Answer

どんなテキストファイルなのかの説明なしでは、回答は付きませんよ。

【VBA】エクセルファイルにtxtファイルのデータをコピペするコードについて

遅くなってすみません。

>「Line Input #Fno, TextLine」の TextLineとはどういう意味ですか？

簡単なコードなので、省きますが、

こんにちは。

こんばんは。

まず、最初に、こちらが理解していないまま推し進めたのですから、いろんな問題は残っているはずです。

こんにちは。

どんなテキストファイルなのかの説明なしでは、回答は付きませんよ。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング