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

解決済みの質問

テキストファイルをエクセルにコピーするマクロ

エクセルマクロの初心者です
以下のようなテキストファイルをエクセルにコピーするマクロを作りたいです。

1、ボタンをクリックするとテキストファイルを選択する画面になる
2、テキストファイルを選択すると、その中から欲しい行のみエクセルのsheet3のA1、B1の順にコピーされる
3、テキストファイルのコピーしたい行はキーワードの間のもの

例(キーワードをAとBとする)
xxx xxxx,xxxxxx xxxx,A
yyyyy yyyyyyy yyyyyy,yyyy
zzzzzzz zzzzzzz z zzzz,B

このような形式のAとBの間にあるyyyyy yyyyyy yyyyyy,yyyyをコピーしたい

xxx xxxx,xxxxxx xxxx,A
yyyyy yyyyyyy yyyyyy,yyyy
xxx xxxx,xxxxxx xxxx,A
ttttt tttttt tttttt,tttt
zzzzzzz zzzzzzz z zzzz,B

このような場合も混在し、このときはtttt tttttt ttttt,ttttのみコピーする

つまり

xxx xxxx,xxxxxx xxxx,A
yyyyy yyyyyyy yyyyyy,yyyy
zzzzzzz zzzzzzz z zzzz,B
xxx xxxx,xxxxxx xxxx,A
yyyyy yyyyyyy yyyyyy,yyyy
xxx xxxx,xxxxxx xxxx,A
ttttt tttttt tttttt,tttt
zzzzzzz zzzzzzz z zzzz,B

このようなテキストに対して実行すると、Sheet3に

yyyyy yyyyyyy yyyyyy,yyyy
ttttt tttttt tttttt,tttt

となるようにしたい

詳しい方、知恵を貸してください
よろしくお願いします。

投稿日時 - 2013-08-23 22:56:07

QNo.8232893

困ってます

質問者が選んだベストアンサー

Option Explicit

Sub SampleCode()

Dim FilePath As String
Dim KeyWord01 As String: KeyWord01 = "A"
Dim KeyWord02 As String: KeyWord02 = "B"
Dim MatchData As New Collection
Dim TextData As String

'■テキストデータを全て取り出す
FilePath = ThisWorkbook.Path & "\sample.txt"
TextData = getTextData(FilePath)

'■キーワードに囲まれた行のデータ
Set MatchData = getData(TextData, KeyWord01, KeyWord02)

'■データの出力
Call OutputData(MatchData)

End Sub

Function getTextData(ByVal FilePath As String)

Dim FH As Object
Dim FSO As Object

'** Objectの生成 **
Set FSO = CreateObject("Scripting.FileSystemObject")

'データ取得(オープンして全データ取得して閉じる)
Set FH = FSO.OPenTextFile(FilePath, 1)
getTextData = FH.ReadAll '全データを返す
FH.Close

Set FH = Nothing
Set FSO = Nothing

End Function

Function getData(ByVal TextData As String, ByVal KeyWord01 As String, ByVal KeyWord02 As String)

Dim i As Integer
Dim MatchData As New Collection
Dim MatchObj As Object
Dim RegObj As Object

'** Objectの生成 **
Set RegObj = CreateObject("VBScript.RegExp")

'該当データを取り出す
'正規表現で抜き出す
RegObj.Pattern = "," & KeyWord01 & vbCrLf & "(.+)" & vbCrLf & ".+," & KeyWord02
RegObj.Global = True
RegObj.IgnoreCase = True

'正規表現に該当するデータを取り出す
Set MatchObj = RegObj.Execute(TextData)

'マッチしたデータを取り出し、Collectionに格納して戻り値とする
For i = 0 To MatchObj.Count - 1
MatchData.Add MatchObj.Item(i).Submatches.Item(0)
Next

Set getData = MatchData

Set RegObj = Nothing
Set MatchObj = Nothing

End Function

Sub OutputData(ByVal MatchData As Collection)

Dim i As Long
Dim r As Long: r = 0
Dim SheetObj As Object

'** Objectの生成 **
Set SheetObj = ThisWorkbook.Sheets(1) '一番最初のシートに出力

SheetObj.Range("A:A").ClearContents 'A列をクリア

For i = 1 To MatchData.Count

r = r + 1
SheetObj.Range("A" & r) = MatchData.Item(i)

Next

Set SheetObj = Nothing

End Sub


■詳細な仕様がわからなかったのである程度推測してみました。
1.キーワードは各行の一番最後にありコンマで区切られている
2.キーワードに挟まれた行は1行であること

■正規表現の簡単な補足
RegObj.Pattern = "," & KeyWord01 & vbCrLf & "(.+)" & vbCrLf & ".+," & KeyWord02
キーワードはコンマで区切られていることを前提としているので
"," & KeyWord01 & vbCrLf  最初のキーワードの行
vbCrLf & ".+," & KeyWord02 次のキーワードの行   .+ は任意の文字列が複数続くケース

その間にある"(.+)" が欲しいデータです。
ここらへんは、ExcelVBAの正規表現を調べてもらったほうがよいと思います。
簡単に説明できる部分でもありませんので。
少しずつ勉強していくと良いと思います。

ところでこんな感じでよかったでしょうか??

投稿日時 - 2013-08-24 21:42:29

ANo.1

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

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

回答(2)

ANo.2

こんな感じでどうでしょうか。
キーワードA,B間の行が複数行ある場合も対応しました(ただし100行まで)。
----------------

Sub test()
Dim fname As String
Dim buf As String
Dim buffer(99) As String
Dim key_s As String
Dim key_e As String
Dim sw As Long
Dim cnt As Long
Dim pt As Long
Dim i As Long

key_s = "A"
key_e = "B"

sw = 0
cnt = 0
pt = 1

fname = Application.GetOpenFilename(filefilter:="Textファイル,*.txt")

If fname <> "False" Then
Open fname For Input As #1
Else
Exit Sub
End If

Do Until EOF(1)
Line Input #1, buf

If Right(buf, Len(key_s) + 1) = "," & key_s Then
For i = 0 To 99
buffer(i) = ""
Next
sw = 1
cnt = 0
GoTo continuelabel
End If
If Right(buf, Len(key_e) + 1) = "," & key_e Then
If cnt <> 0 Then
For i = 1 To cnt
Worksheets("sheet3").Cells(1, pt + i - 1) = buffer(i - 1)
Next
End If
pt = pt + cnt
cnt = 0
sw = 0
GoTo continuelabel
End If

If sw = 1 Then
buffer(cnt) = buf
cnt = cnt + 1
End If

continuelabel:
Loop

Close #1

End Sub

投稿日時 - 2013-08-28 13:44:22

あなたにオススメの質問