.xlsxのセルに.txtの文字wコピーするVBA

質問

テキストファイルの　テキスト.txtにおいて
文字列が
<a>A<b>B
という文字列があるとしまして
エクセルマクロを使って
エクセルファイルのM.xlsxを作成して
そのエクセルファイルのA1セルに
テキスト.txtの
文字Aをコピーし
また同様に
M.xlsxのエクセルファイルのB1セルにテキスト.txtの
文字Bをコピーする
そういう操作をするVBAコードを
御教示いただけますでしょうか
よろしくお願い致します
win10 office365

回答No.2

HohoPapa · ベストアンサー

文字Ａ、文字Ｂは、複数文字の文字列ですか？
更に、改行文字が含まれますか？
<a>、<b>は、本当は別な文字列ですか？
更に文字数は変動しますか？
テキスト.txt　の文字コードはUTF-8ですか？

これらを前提にコードを書いてみました。
よかったら試してください。

なお、
>M.xlsxを作成して
この作成先は、マクロ格納ブックと同じフォルダーとしました。
更に、
>テキストファイルの　テキスト.txt
このファイルのフルパスは、
ソースコードにハードコーディングしました。

Option Explicit

Sub Sample()

　Const MyFile = "D:\TestDir\テキスト.txt"
　Const Key1 = "<a>"
　Const Key2 = "<b>"
　Const PutBokName = "M.xlsx"
　Dim buf As String
　Dim Len1 As Long
　Dim Len2 As Long
　Dim Pos1 As Long
　Dim Pos2 As Long
　Dim PutBook As Workbook

　With CreateObject("ADODB.Stream")
　　.Charset = "UTF-8"
　　.Open
　　.LoadFromFile MyFile
　　buf = .ReadText
　　.Close
　End With

　Len1 = Len(Key1)
　Len2 = Len(Key2)
　Pos1 = InStr(buf, Key1)
　Pos2 = InStr(buf, Key2)

　If Len1 = 0 Then
　　MsgBox Key1 & " が見つかりません"
　　Exit Sub
　End If
　If Len2 = 0 Then
　　MsgBox Key2 & " が見つかりません"
　　Exit Sub
　End If

　Set PutBook = Workbooks.Add
　With PutBook.Sheets(1)
　　.Cells(1, 1).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1))
　　.Cells(1, 2).Value = Right(buf, Len(buf) - (Pos2 + Len2 - 1))
　End With

　PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName
　PutBook.Close

End Sub

回答No.3

chayamati

テキストファイル（CSV)の情報をエクセルファイルに取り込むには
次の二つが思いつきますが、取込先のセルの指定が大変なので、
これはあきらめましょう
このセル位置が無いと、情報はセルＡ１から順に取り込まれます
新規にSheetを用意し、これに取り込んだSheetより式で成形します

１.コピペ（見出し行を含める）
２.テキスファイルをインポートする
　《データリボン》《テキスCSVから》《ルート》《テキストファイル名》と進みます。

回答No.1

kkkkkm

テキストファイルはアクセスやエクセルファイルのようにセルやフィールドなどで指定できないので質問の例の状態
テキスト.txtが
<a>A<b>B
と確定して

Sub Test()
Dim buf As String
Dim NewBook As Workbook

Set NewBook = Workbooks.Add

NewBook.SaveAs ThisWorkbook.Path & "\M.xlsx"

With NewBook.Sheets("Sheet1")
Open "C:\Ok\テキスト.txt" For Input As #1
Do Until EOF(1)
Line Input #1, buf
If InStr(buf, "<a>") > 0 Then
.Range("A1").Value = Mid(buf, InStr(buf, "<a>") + 3, 1)
End If
If InStr(buf, "<b>") > 0 Then
.Range("B1").Value = Mid(buf, InStr(buf, "<b>") + 3, 1)
End If
Loop
Close #1
End With
Set NewBook = Nothing
End Sub