エクセルファイル 行列入れ替えたもの同時作成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
-------------------------------
お礼
ありがとうございます。 やりたかったことが出来ました。