[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ｔｘｔファイルから特定文字列に挟まれた行情報全部を別シートに保存したい』（老眼です）
テキストファイルに保存してある文字行の中から、特定の文字行に挟まれた行を選択し、Excel2010でマクロを使って、Excelに貼り付けたいです。
例えば、
＜テキストファイル例＞
※例なので実際のテキスト内容は下記に限らず。
東京 A B 大阪 B 名古屋 A 神戸 C D 広島 D E 福岡 B 鹿児島 E
北海道 B 東京 A 大阪 A 名古屋 D 広島 B 福岡 C 鹿児島 D
北海道 B 山形 A B 大阪 C D E 広島 福岡 A 宮崎 D E
青森 A B 東京 B C 大阪 C D 京都 岡山 A 福岡 B 那覇 D
＜上記の内、コピーしたい行＞
※大阪から福岡までの行情報全部を選択したいです。 大阪 A 名古屋 D 広島 B 福岡 C
大阪 A 名古屋 D 広島 B 福岡 C
大阪 C D E 広島 福岡 A
大阪 C D 京都 岡山 A 福岡 B
ですが実際は、txtデータをExcelにはり付けるところまでは動くのですが、そのあと
大阪
名古屋
広島
福岡
…のように最初の1セット目の項目までを抽出したところで終わってしまいます。どこをどう変更すればよいか、お知恵をお貸しください。
（以下全文）
Sub PasteFromCSV()
Const CSV_FILE = "C:\Users\user\Documents\test.txt"
Dim ReadWBk As Workbook
Dim WriteWBk As Workbook
Dim WriteSht As Worksheet
Dim Rng As Range
Set WriteWBk = ActiveWorkbook
Set WriteSht = WriteWBk.ActiveSheet
Set ReadWBk = Workbooks.Open(CSV_FILE)
'Set Rng = ReadWBk.Worksheets.Item(1).UsedRange
'Range("A1:A1700").Copy
Dim startStr As String
Dim endStr As String
Dim copyFlag As Boolean
Dim writeRow As Long
startStr = "大阪"
endStr = "福岡"
copyFlag = False
writeRow = 1
For Each c In ReadWBk.Worksheets(1).Range("A1:A" & Range("A1").End(xlDown).Row)
If c = startStr Then copyFlag = True
If copyFlag Then
WriteSht.Cells(writeRow, 1) = c
writeRow = writeRow + 1
If c = endStr Then Exit For
End If
Next
End Sub
＜ 使用 Excel：Excel2010、使用 OS：unknown ＞
＞ If c = endStr Then Exit For
ループを抜けずに継続したいということでしょうか？
もっと、簡潔に記述できそうなきもしますが
きっと、こんな感じで、
If c = startStr Then
copyFlag = True
ElseIf c = endStr Then
copyFlag = False
WriteSht.Cells(writeRow, 1) = c
writeRow = writeRow + 1
End If
If copyFlag Then
WriteSht.Cells(writeRow, 1) = c
writeRow = writeRow + 1
End If
（マナ） 2018/01/04(木) 21:12
If c = startStr Then copyFlag = True
If copyFlag Then
WriteSht.Cells(writeRow, 1) = c
writeRow = writeRow + 1
End If
If c = endStr Then copyFlag = False
（マナ） 2018/01/04(木) 21:58
老眼ですさん、
全くの別案です、 元のテキストファイルを加工して同フォルダにtest_大阪_福岡.txtを新たに作成します。 それを読み込むだけにする
Sub test()
Dim fn As String, txt As String, a() As String, i As Long
fn = Application.GetOpenFilename("テキストファイル,*.txt")
If fn = "False" Then Exit Sub
txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
With CreateObject("VBScript.RegExp")
.Global = True: .MultiLine = True
.Pattern = "大阪(.*[\r\n]+.)+?(福岡).*"
ReDim a(1 To .Execute(txt).Count)
For i = 0 To .Execute(txt).Count - 1
a(i + 1) = .Execute(txt)(i)
Next
End With
Open Replace(fn, ".txt", "_大阪_福岡.txt") For Output As #1
Print #1, Join(a, String(2, vbCrLf))
Close #1
Workbooks.OpenText (Replace(fn, ".txt", "_大阪_福岡.txt"))
End Sub
（seiya） 2018/01/04(木) 22:02
＞マナさん
あ！そうです。ありがとうございます。動作後のイメージはこんな感じです。
可能ならば、B列以降のデータ（A、B、Cなどの…）も落とさずにペーストできるとよいのですが、どのように記述するのが良いでしょうか？例ですと、F列までしかデータは入っていませんが、実際はI列くらいまでデータが入ることもあり、汎用性のあるコードを書ければよいのですが、私では全然力不足でして…。質問ばかりですみませんが、良い案ありましたらお願いします。
＞seiyaさん
すごいです。こんな短時間で別案を考えて下さったのですね。ありがとうございます。
試してみたのですが、オーバーフロー？なのか途中でExcelが動かなくなってしまいました＞＜
＞元のテキストファイルを加工
とは具体的にどうすべきでしょうか？
もしかしてここで引っかかっているのかなという気もするのですが。
お手数おかけしてすみません。よかったらお願いします。
（老眼です） 2018/01/05(金) 11:17
おそらくデータ量が想定していたものとは比べ物にならない程大量なのでしょうね。
此方で試してください。
Sub test()
Dim fn As String, txt As String, a() As String, n As Long, mtch As Object, m As Object
fn = Application.GetOpenFilename("テキストファイル,*.txt")
If fn = "False" Then Exit Sub
txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
With CreateObject("VBScript.RegExp")
.Global = True: .MultiLine = True
.Pattern = "大阪(.*[\r\n]+.)+?(福岡).*"
Set mtch = .Execute(txt)
ReDim a(1 To mtch.Count)
For Each m In mtch
n = n + 1: a(n) = m.Value
Next
End With
Open Replace(fn, ".txt", "_大阪_福岡.txt") For Output As #1
Print #1, Join(a, String(2, vbCrLf))
Close #1
Workbooks.OpenText (Replace(fn, ".txt", "_大阪_福岡.txt"))
End Sub
（ seiya） 2018/01/05(金) 12:24
前提条件
・プロシージャ名、変数名から推測して読み込むテキストファイルは「CSV形式」
・「大阪」で始まる行から「福岡」で始まる行までは、シートに取り込むが、「福岡」で始まる行の次の行から、
「大阪」で始まる行の前の行はシートに取り込む必要がない。
・「大阪」と「福岡」の順は逆転しない。（「福岡」から「大阪」でサンドイッチされているものは対象外。）
主な処理フロー
（１）OPENステートメントでテキストファイルを開いて1行ずつ読込
（２）読込行は変数「buf」に格納
（３）「buf」が「大阪」で始まっていたら「フラグ」をTreuに変更
（４）「フラグ」がTureなら、「buf」をシートに出力
（５）「buf」が「大阪」で始まっていたら「フラグ」をFalseに変更
（６）次の行を読み込む
（７）（２）から（６）をテキストファイルの最終行までループ
コードにしてみるとこんな感じになりました。
Sub Sample()
'==変数の宣言とか
Const CSV_FILE = "C:\Users\user\Documents\test.txt"
Dim WS As Worksheet
Set WS = ThisWorkbook.Worksheets(1)
Dim buf As String
Dim 出力行 As Long
出力行 = 1
Dim フラグ As Boolean
フラグ = False 'Boolean型の初期値がFALSEなので省略可
'==主処理
Open CSV_FILE For Input As #1
Do Until EOF(1)
Line Input #1, buf
If buf Like "大阪*" Then フラグ = True
If フラグ = True Then
WS.Cells(出力行, "A").Resize(, UBound(Split(buf, ",")) + 1).Value = _
Split(buf, ",")
出力行 = 出力行 + 1
End If
If buf Like "福岡*" Then フラグ = False
Loop
Close #1
'==後処理（オブジェクト解放）
Set WS = Nothing
End Sub
（もこな２） 2018/01/05(金) 12:46
＞seiyaさん
度々ありがとうございます。
情報量を1000行程度に減らしたうえで２度目に頂いたコードも試したのですが、やはり途中で止まってしまいました。せっかく書いて頂けたので何とか動かしてみたいのですが…。何かデータ側に適合しない点がないか少し考えてみます。
＞もこな２さん
動作、完璧でした。しかも、処理フロー、コード解説まで丁寧にしてくださって大変助かります。
一つ伺ってみたいのですが、地名をA列に、アルファベット集合をB列にペーストするのは難しいでしょうか？（この形に持っていけると、その後の作業性が格段に上がるのです）
お時間あれば…でよいです。よろしくお願いします。
（老眼です） 2018/01/05(金) 14:30
>情報量を1000行程度に減らしたうえで２度目に頂いたコードも試したのですが、やはり途中で止まってしまいました。
変ですねーー。
此方では 60000行超で試しています。 抽出行は 55000行超ですが、ファイル選択後2秒そこそこで完了します。 （ seiya） 2018/01/05(金) 14:37
WS.Cells(出力行, "B").Value = Replace(Join(Split(buf, ","), "・"), Split(buf, ",")(0) & "・", "") 出力行 = 出力行 + 1 End If
ブランク値はくっつけないとかだと、ちょっと難易度あがりますが、整数型とString型の変数（たとえば「i、tmp」など）を用意（宣言）して
If フラグ = True Then
WS.Cells(出力行, "A").Value = Split(buf, ",")(0)
tmp = ""
For i = 1 To UBound(Split(buf, ","))
If Split(buf, ",")(i) <> "" Then tmp = tmp & Split(buf, ",")(i) & "・"
Next i
If Len(tmp) > 0 Then WS.Cells(出力行, "B").Value = Left(tmp, Len(tmp) - 1)
出力行 = 出力行 + 1
End If
こんな感じでしょうか。（ごちゃごちゃしちゃってますが・・・）
（もこな２） 2018/01/05(金) 15:29
ローカルウィンドウでみると。
mtchの下位に[NewEnum]ってあって ＜サポートされていないオブジェクト型＞ って出てるので、なんか参照設定が必要なのかも？（私のスキルではこれ以上解らないです。。）
（もこな２） 2018/01/05(金) 15:45
一応実行データをアップしておきます。 データが元々違っていれば、エラーもありうるでしょう。
http://firestorage.jp/download/f9ac16db556632fcc57a4cceccbb113e0d68db34
ダウンロードパスワード mebw77in
（seiya） 2018/01/05(金) 16:04
Dim x As String, f As String, a As String, b As String, buf As String, i As Long, j As Long, k As Long
Cells.ClearContents
x = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
f = "C:\Users\user\Documents\test.txt"
Open f For Input As #1
Do Until EOF(1)
Line Input #1, buf
If InStr(buf, "大阪") > 0 Then flg = True
If flg Then
a = buf
b = ""
For i = 1 To Len(buf)
For j = 1 To Len(x)
If Mid(buf, i, 1) = Mid(x, j, 1) Then
a = Replace(a, Mid(buf, i, 1), "")
b = b & Mid(x, j, 1)
Exit For
End If
Next j
Next i
k = k + 1
Cells(k, 1).Resize(, 2).Value = Array(a, b)
End If
If InStr(buf, "福岡") > 0 Then flg = False
Loop
Close #1
End Sub
（mm） 2018/01/05(金) 16:45
＞seiyaさん
実行データ、ありがとうございました。どうやら地名の前の半角スペースの有無が原因だったようです。
完全にこちらの説明不足です。すみません。ここで例を示す際に最初に半角スペースを入れないとtxtデータと同じように表記できなかったのであえてそうしたのですが、実際のデータはスペースが入ってないものでした（汗）
こちらのデータにも同じように半角スペースを入れてみると、動きました。
動作結果はもともとこちらがイメージしていたそのままを再現していただけました。本当にありがとうございます！
＞もこな２さん
２パターンも考えていただいたき、ありがとうございます。
試してみましたが、１つ目のパターンですとA列にもB列にも地名＋アルファベット集合がペーストされ、２つ目はA列に地名＋アルファベット集合がペーストされました。
もこな２さんのおっしゃるようにファイルのレイアウトが違うのかもしれません。
うまく説明できず申し訳ありません。
＞ｍｍさん
ありがとうございます。この形までもっていけるんですね…。すごいです。
これがあれば、相当に作業効率が良くなるので助かります。
しかし、皆さん本当にすごいです。アプローチの仕方も様々で、勉強になります。
何時間何日かけてもエラーばかりのコードしか書けない老眼…、時々嫌になりますが、ちまちまと頑張ります。また、わからないことがあれば質問させてください。
（老眼です） 2018/01/05(金) 19:58
スペースが無くても動くと思うのですが？
とりあえず、こんな形でA/B列が抽出されます。
Sub test()
Dim fn As String, txt As String, a() As String, n As Long, mtch As Object, m As Object, s As Object
fn = Application.GetOpenFilename("テキストファイル,*.txt")
If fn = "False" Then Exit Sub
txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
With CreateObject("VBScript.RegExp")
.Global = True: .MultiLine = True
.Pattern = ""
.Pattern = "^大阪(.*[\r\n])+?(福岡).*"
Set mtch = .Execute(txt)
ReDim a(1 To mtch.Count)
.Pattern = "^(.+?\t)(.*)"
For Each m In mtch
n = n + 1
For Each s In .Execute(m.Value)
a(n) = a(n) & s.submatches(0) & Replace(s.submatches(1), vbTab, "")
Next
Next
End With
Open Replace(fn, ".txt", "_大阪_福岡.txt") For Output As #1
Print #1, Join(a, String(2, vbCrLf))
Close #1
Workbooks.OpenText (Replace(fn, ".txt", "_大阪_福岡.txt"))
End Sub
（seiya） 2018/01/05(金) 20:25
すみません、スペースの有無でないとすると原因がよくわからないのです。スペース以外にデータパターンに違いがないように思え、入れてみると動くのでてっきりこれかと…。
先ほど新たに提示いただいたコードですが、”インデックスが有効範囲にありません”とのエラーで実行できませんでした。データは上記で試させて頂いたのと同じものなのですが…。
（老眼です） 2018/01/05(金) 22:11
最後のコードは文頭にスペースが無いものとしてアップしています。 ですので、マッチする文字列が抽出されないので >”インデックスが有効範囲にありません” のエラーが出ます。
両方のデータでマッチさせるには、Patternを
.Pattern = "^ *大阪(.*[\r\n])+?( *福岡).*"
に差し替えてください。
（seiya） 2018/01/05(金) 22:35
何と。もうそこまで考えて頂いていたのですね。
おかげさまでコード実行できました。結果もとてもきれいな形で出力され、思い描いたとおりに作業を進められそうです。
長らくの悩みがようやく解決し、助かりました！
（老眼です） 2018/01/06(土) 10:08
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.