エクセルファイル 行列入れ替えたもの同時作成VBA

質問

あるxmlファイルを一旦テキストファイルにして
そこから数値をエクセルファイルに移行して
ひとつはM.xlsxとし
それに続いて行列を入れ替えた
エクセルファイルR.xlsxを
作りたいのですが
M.xlsx　R.xlsxのそれぞれを作るコードを
単純に　合体させただけでは
どうも　できません
M.xlsxだけ　また　R.xlsxだけの
作成するコードは　出来たのですが
それぞれ別のマクロとして実行することになります
ひとつのマクロでM.xlsx　R.xlsx同時に
作成するVBAコードは可能でしょうか
宜しくお願い致します
ちなみに該当コードを単純化して
合体したのが以下のものです
win10 office10

Sub 783縦()
Dim FileName As Variant

ChDir "\\DESKTOP-O5\f"
FileName = Application.GetOpenFilename(FileFilter:="xmlファイル,*.xml")
If FileName = False Then
MsgBox "キャンセルされました"
Exit Sub
End If
FileCopy FileName, Left(FileName, InStrRev(FileName, "\")) & "テキスト.txt"

Const MyFile = "\\DESKTOP-O5\f\テキスト.txt"

Const Key1 = "<Name>"
Const Key2 = "</Name>"

Const Key3 = "<NameKana>"
Const Key4 = "</NameKana>"

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 Len3 As Long
Dim Len4 As Long
Dim Pos3 As Long
Dim Pos4 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)

Len3 = Len(Key3)
Len4 = Len(Key4)
Pos3 = InStr(buf, Key3)
Pos4 = InStr(buf, Key4)

Set PutBook = Workbooks.Add
With PutBook.Sheets(1)

.Cells(1, 1).Value = "氏名"

.Cells(1, 2).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1))

.Cells(2, 1).Value = "氏名カナ"

.Cells(2, 2).Value = Mid(buf, Pos3 + Len3, Pos4 - (Pos3 + Len3))

'クリップボードをクリア
Application.CutCopyMode = False

PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName
End With

Const PutBokName = "R.xlsx"
Dim buf As String
Dim Len1 As Long
Dim Len2 As Long
Dim Pos1 As Long
Dim Pos2 As Long

Dim Len3 As Long
Dim Len4 As Long
Dim Pos3 As Long
Dim Pos4 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)

Len3 = Len(Key3)
Len4 = Len(Key4)
Pos3 = InStr(buf, Key3)
Pos4 = InStr(buf, Key4)

Set PutBook = Workbooks.Add
With PutBook.Sheets(1)

.Cells(1, 1).Value = "氏名"

.Cells(2, 1).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1))

.Cells(1, 2).Value = "氏名カナ"

.Cells(2, 2).Value = Mid(buf, Pos3 + Len3, Pos4 - (Pos3 + Len3))

'クリップボードをクリア
Application.CutCopyMode = False

PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName
End With

End Sub

-------------------------------

回答No.5

kkkkkm

蛇足です。

現状のコードだと多分複数の氏名があった場合最初の1個しか取得できていないと思うのですが
複数を取得する場合はインポートをつかうといいのではないかと思います。

MとRが逆かもしれませんがとりあえず参考までに
スキーマがどうのこうのというメッセージが出たらOKで進んでください。

Sub TestXML()
Dim FileName As Variant
Dim WbM As Workbook
Dim WbR As Workbook
Dim M_Name As String
Dim R_Name As String

M_Name = "M.xlsx"
R_Name = "R.xlsx"

ChDir "\\DESKTOP-O5\f"
FileName = Application.GetOpenFilename(FileFilter:="xmlファイル,*.xml")
If FileName = False Then
MsgBox "キャンセルされました"
Exit Sub
End If

Set WbM = Workbooks.Add

With WbM.Sheets("Sheet1")

' Application.DisplayAlerts = False

ActiveWorkbook.XmlImport URL:=FileName, ImportMap:=Nothing, _
Overwrite:=True, Destination:=.Range("$A$1")

' Application.DisplayAlerts = True

.Range("$A$1").Value = "氏名"
.Range("$B$1").Value = "氏名カナ"

.ListObjects(1).Unlist
.Range("$A$1").CurrentRegion.ClearFormats

.Range("$A$1").CurrentRegion.Copy

End With

Set WbR = Workbooks.Add

WbR.Sheets("Sheet1").Range("$A$1").PasteSpecial Transpose:=True

Application.CutCopyMode = False

WbM.SaveAs ThisWorkbook.Path & "\" & M_Name
WbR.SaveAs ThisWorkbook.Path & "\" & R_Name

Set WbM = Nothing
Set WbR = Nothing

End Sub

回答No.4

HohoPapa

ポストされたコードが抜粋なので定かではありませんが
後半で行っている

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)

Len3 = Len(Key3)
Len4 = Len(Key4)
Pos3 = InStr(buf, Key3)
Pos4 = InStr(buf, Key4)

は、同じことを無駄に重複して行っているの可能性を疑います。
もしそうであれば、
コメントアウトする、あるいは、行削除します。

回答No.3

HohoPapa

期待通り動作するSubプロシージャが２つある。
これを１つのSubプロシージャにまとめたい。
ということと思います。

１つのSubプロシージャの中に
同じ変数の宣言、同じ名前の定数を複数書くことはできません。

提示のコードの場合

Dim buf As String
Dim Len1 As Long
Dim Len2 As Long
Dim Pos1 As Long
Dim Pos2 As Long
Dim Len3 As Long
Dim Len4 As Long
Dim Pos3 As Long
Dim Pos4 As Long
Dim PutBook As Workbook

これらが重複しています。

更に、
Const PutBokName = "M.xlsx"
Const PutBokName = "R.xlsx"
これが重複しています。

提示コードを生かすのであれば
例えば、以下のようなコードとなります。

Sub Sample()

Dim FileName As Variant

ChDir "D:\TestDir\DirX"
FileName = Application.GetOpenFilename(FileFilter:="xmlファイル,*.xml")
If FileName = False Then
MsgBox "キャンセルされました"
Exit Sub
End If
FileCopy FileName, Left(FileName, InStrRev(FileName, "\")) & "テキスト.txt"
Const MyFile = "D:\TestDir\DirX\テキスト.txt"
Const Key1 = "<Name>"
Const Key2 = "</Name>"
Const Key3 = "<NameKana>"
Const Key4 = "</NameKana>"

Const PutBokName_M = "M.xlsx"
Dim buf As String
Dim Len1 As Long
Dim Len2 As Long
Dim Pos1 As Long
Dim Pos2 As Long

Dim Len3 As Long
Dim Len4 As Long
Dim Pos3 As Long
Dim Pos4 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)

Len3 = Len(Key3)
Len4 = Len(Key4)
Pos3 = InStr(buf, Key3)
Pos4 = InStr(buf, Key4)

Set PutBook = Workbooks.Add
With PutBook.Sheets(1)
.Cells(1, 1).Value = "氏名"
.Cells(1, 2).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1))
.Cells(2, 1).Value = "氏名カナ"
.Cells(2, 2).Value = Mid(buf, Pos3 + Len3, Pos4 - (Pos3 + Len3))
'クリップボードをクリア
Application.CutCopyMode = False
PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName_M
End With

Const PutBokName_R = "R.xlsx"
' Dim buf As String
' Dim Len1 As Long
' Dim Len2 As Long
' Dim Pos1 As Long
' Dim Pos2 As Long

' Dim Len3 As Long
' Dim Len4 As Long
' Dim Pos3 As Long
' Dim Pos4 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)

Len3 = Len(Key3)
Len4 = Len(Key4)
Pos3 = InStr(buf, Key3)
Pos4 = InStr(buf, Key4)
Set PutBook = Workbooks.Add
With PutBook.Sheets(1)
.Cells(1, 1).Value = "氏名"
.Cells(2, 1).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1))
.Cells(1, 2).Value = "氏名カナ"
.Cells(2, 2).Value = Mid(buf, Pos3 + Len3, Pos4 - (Pos3 + Len3))
'クリップボードをクリア
Application.CutCopyMode = False
PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName_R
End With

End Sub

コーディングする人によって議論の分かれるところですが
Dim
Const
の記述は、
Subプロシージャの最初にまとめて書いたほうがいいと思います。

回答No.2

kkkkkm

質問のコードでテキスト.txtにKeyが存在しない場合エラーになると思いますよ。

回答No.1

kkkkkm

xmlファイルそのものはテキストファイルなので"テキスト.txt"にコピーする必要は無いと思います。
以前にそうしたいのはクリックしただけでメモ帳などのテキストエディタで開けるからそいうことかなと思って追加回答しましたが、中身を取得するのでしたらxmlのままでいけます。

> M.xlsxだけ　また　R.xlsxだけの
> 作成するコードは　出来たのですが

でしたら

Sub Test()
Call Mxlsxだけ
Call Rxlsxだけ
End Sub

Sub Mxlsxだけ()
出来ているM.xlsxだけ作成するコード
End Sub

Sub Rxlsxだけ()
出来ているR.xlsxだけ作成するコード
End Sub

とすれば書き直すこともないと思います。

お礼

やってみます　有り難う御座いました。またxmlはテキストファイル扱いでいける旨　有り難う御座いました。

Powered by GRATICA