• 締切済み

XMLをエクセルに取り込むマクロその2

以下のtest2.xmlを <?xml version="1.0" encoding="UTF-8" ?> <McXMLRoot> <McXMLData> <McXMLPageInfo> <page>1</page> <overLay></overLay> <partition>PAGE</partition> </McXMLPageInfo> <McXMLPageData> <現頁> <value>0001</value> </現頁> <作成日付> <value>平成21年 6月 1日現在</value> </作成日付> <Group0001> <氏名> <value>あああ</value> </氏名> <生年月日> <value>昭和48年 2月21日</value> </生年月日> </Group0001> <Group0002> </Group0002> <Group0003> </Group0003> </McXMLPageData> <McXMLPageInfo> <page>2</page> <overLay></overLay> <partition>PAGE</partition> </McXMLPageInfo> <McXMLPageData> <現頁> <value>0004</value> </現頁> <作成日付> <value>平成21年 6月 1日現在</value> </作成日付> <Group0001> <氏名> <value>いいい</value> </氏名> <生年月日> <value>昭和55年 12月5日</value> </生年月日> </Group0001> <Group0002> <法人名> <value>AAA株式会社</value> </法人名> <住所> <value>AA市1丁目1番地</value> </住所> </Group0002> <Group0003> <支店名> <value>BBB営業所</value> </支店名> </Group0003> </McXMLPageData> </McXMLData> </McXMLRoot> を読むマクロ↓ Public Const XmlPass = "D:\temp\test2.xml" Public y As Integer Public ctr As Long Public Sub Auto_Open() 'On Error Resume Next Workbooks.OpenXML Filename:= _ XmlPass _ , LoadOption:=xlXmlLoadImportToList Range("A1").Select Call RetsuSakujo Call parseXML End Sub Private Sub RetsuSakujo() ctr = 1 Do Until "" = Trim(Worksheets("sheet1").Cells(1, ctr)) If "eform" = Trim(Worksheets("sheet1").Cells(1, ctr)) Or _ "page" = Trim(Worksheets("sheet1").Cells(1, ctr)) Or _ "overLay" = Trim(Worksheets("sheet1").Cells(1, ctr)) Or _ "partition" = Trim(Worksheets("sheet1").Cells(1, ctr)) Then Worksheets("sheet1").Columns(ctr).EntireColumn.Delete ctr = 0 End If ctr = ctr + 1 Loop End Sub Private Sub parseXML() Dim objDOM, rtResult y = 1 Set objDOM = CreateObject("MSXML2.DOMDocument") rtResult = objDOM.Load(XmlPass) If rtResult = True Then Call setTitle(objDOM.childNodes) End If Set objDOM = Nothing End Sub Sub setTitle(objNode) Dim obj For Each obj In objNode If obj.hasChildNodes Then If obj.parentNode.nodeName <> "McXMLRoot" And _ obj.parentNode.nodeName <> "McXMLData" And _ obj.parentNode.nodeName <> "McXMLPageData" And _ obj.parentNode.nodeName <> "McXMLPageInfo" _ Then If SearchChild(obj.childNodes) = False Then If y >= ctr Then Exit Sub End If Cells(1, y).Value = obj.parentNode.nodeName y = y + 1 End If End If Call setTitle(obj.childNodes) End If Next End Sub Private Function SearchChild(objNode) As Boolean Dim obj For Each obj In objNode If obj.hasChildNodes Then SearchChild = True Else SearchChild = False End If Next End Function を作成してエクセルマクロを試したところ、 タイトルが 現頁,作成日付,氏名,生年月日,現頁2,作成日付2,氏名2,生年月日2,法人名 となります。が、本当は 現頁,作成日付,氏名,生年月日,法人名,住所,口座番号,口座名義人,支店名 としたいのです。(エクセルでXMLソースを表示した時の順序) なにかよい方法があれば教えてください。 よろしくお願いします。

  • torum
  • お礼率61% (19/31)

みんなの回答

  • yyr446
  • ベストアンサー率65% (870/1330)
回答No.1

提示のコードだと、各要素(node)を階層関係に関係なく順次に読み込んで、IF文で要素名(nodeName)該当する要素名のみ列記しているからそうなるのです。そもそもXMLをシートにインポートで貼り付け、タイトル行のみ 消しこんで、別途XMLアクセスしてセットしているから、ややこしくなり、汎用性をそこねているのです。どちらかのやり方に統一しましょう。 まず、 -XMLの構造を理解して下さい。 -次にDOM(ドキュメントオブジェクトモデル)のアクセス方法も理解して下さい。 XMLの構造はスキーマー定義(XSD)に記述するのですが、無い場合は自分で構造を把握して下さい。提示のXMLの構造だと <McXMLRoot>要素がルート(一番上の親要素)となり、<McXMLData>要素があり、 <McXMLData>要素の下に<McXMLPageInfo>要素と<McXMLPageData>要素が ページ数分あります。 <McXMLPageData>要素の下に<現頁>、<作成日付>、<Group0001>、<Group0002>、<Group0003>の要素が一つづつあります。 <Group0001>の要素の下が<氏名>要素と<生年月日>要素で、 <Group0002>の要素の下が<法人名>要素と<住所>要素で、 <Group0003>の要素の下が<支店名>要素 となっています。つまり <McXMLData>  <McXMLPageInfo>   <page>   <overLay>   <partition>  <McXMLPageData>   <現頁>   <作成日付>   <Group0001>    <氏名>    <生年月日>   <Group0002>    <法人名>    <住所>   <Group0003>    <支店名> の階層構造で、<McXMLPageData>要素が複数繰り返されてます。 この構造に沿って、要素の名前を取り出し1行目にセットし、中身のデータは、変数(配列)に保持させ、<McXMLPageData>要素毎に行ブレークして各列にセットするようにした方がよいと思います。 XMLの理解については http://www6.airnet.ne.jp/manyo/xml/ あたりがわかりやすいです。 VBAでのXML解析は参考サイトがなかなかありませんが、 http://msdn.microsoft.com/ja-jp/library/aa468547.aspx とか http://msdn.microsoft.com/ja-jp/library/ms256471(VS.80).aspx とか http://www.kanaya440.com/contents/tips/vbs/003.html http://blog.goo.ne.jp/xmldtp/e/c2d0c185fbd25cbae4a59adff625ce43 ですかね。

関連するQ&A

  • VBSでXMLを読込、検索結果をテキスト出力

    VBSのソースについてご教授下さい。 【作りたい機能】 XMLファイルを読み込み、任意のエレメントを検索するスクリプトを VBSで作成しようとしています。 【状況】 ダイアログで表示させる方法はわかりました。  参照  http://www.atmarkit.co.jp/fxml/rensai/msxml01/msxml03.html 01 : Dim objDOM, rtResult 02 : 03 : Set objDOM = WScript.CreateObject("MSXML2.DOMDocument") 04 : rtResult = objDOM.load("Sample.xml") 05 : If rtResult = True Then 06 : procDispDatas objDOM.childNodes 07 : End If 08 : Set objDOM = Nothing 09 : 10 : Sub procDispDatas(objNode) 11 : Dim obj 12 : For Each obj In objNode 13 : If obj.nodeType = 3 and obj.parentNode.nodeName = "title" Then 14 : MsgBox obj.parentNode.nodeName & " : " & obj.nodeValue 15 : End If 16 : If obj.hasChildNodes Then 17 : procDispDatas obj.childNodes 18 : End If 19 : Next 20 : End Sub この結果をテキストファイルに出力させる方法に 困っております。 どこにどのように記載すればいいか 教えていただきたく存じます。 よろしくお願いいたします

  • EXCELVBA XML処理

    こんにちは、 下記のプログラムを作成したのですが、 (すいません、わかりづらいかもしれません。) <DIMENSION Name="E1">内の<HIERARCHY>タグ内にある <PARENT>と<CHILD>の値をセルに貼り付けようとしているのですが、 現在、下記二点で悩んでいまして、何か方法などありましたらお願い致します。 1:<DIMENSION Name="E1">処理のときに、セルにNAMEの値E1を出力  しているのですが、二回表示されてしまう。  (おそらく、<MEMBERS>と<HIERARCHY>と二つタグがあるので  そのせいかと思ったのですが、回避方法が変わりません。) 2:<DIMENSION Name="E1">だけでよいのだが、  <DIMENSION Name="Z1">まで処理を行っている  (<DIMENSION Name="E1">を抜けたという判断方法がわからず・・) VBAコード----------- Option Explicit Dim ia As Long Dim flg As Integer Private Sub CommandButton2_Click() Const cnsTITLE = "テキストファイル読み込み処理" Const cnsFILTER = "全てのファイル (*.*),*.*" Dim xlAPP As Application ' Applicationオブジェクト Dim strXMLFile As String Dim objDOM As MSXML2.DOMDocument Dim rtResult Set xlAPP = Application xlAPP.StatusBar = "読み込むファイル名を指定して下さい。" strXMLFile = xlAPP.GetOpenFilename(FileFilter:=cnsFILTER, _ Title:=cnsTITLE) If StrConv(strXMLFile, vbUpperCase) = "FALSE" Then Exit Sub Set objDOM = New MSXML2.DOMDocument rtResult = objDOM.Load(strXMLFile) If rtResult = True Then ia = 0 flg = 0 procDispDatas objDOM.childNodes Else MsgBox "読み込み失敗" End If Set objDOM = Nothing End Sub Sub procDispDatas(objNode) Dim obj For Each obj In objNode If (obj.parentNode.nodeName = "DIMENSION") Then '<DIMENSION >タグ内処理か判断 If (obj.parentNode.Attributes.getNamedItem("Name").nodeValue = "E1") Then '<DIMENSION Name="E1">タグ内処理か判断 ia = ia + 1 Cells(ia, 1).Value = _ obj.parentNode.Attributes.getNamedItem("Name").nodeValue & " : " flg = 1 End If ElseIf (flg = 1) Then If (obj.parentNode.nodeName = "HIERARCHY") Then '<HIERARCHY>タグ内処理か判断 flg = 2 End If ElseIf (flg = 2) Then If (obj.parentNode.nodeName = "NODE") Then '<NODE>タグ内処理か判断 flg = 3 End If ElseIf (flg = 3) Then Select Case obj.parentNode.nodeName Case "PARENT" '<PARENT>タグ内処理か判断 ia = ia + 1 Cells(ia, 1).Value = _ obj.parentNode.nodeName & " : " & _ obj.nodeValue Case "CHILD" '<CHILD>タグ内処理か判断 ia = ia + 1 Cells(ia, 1).Value = _ obj.parentNode.nodeName & " : " & _ obj.nodeValue Case Else End Select End If If obj.hasChildNodes Then procDispDatas obj.childNodes End If Next End Sub XMLファイル---------- <?xml version = "1.0" encoding="UTF-16" ?> <HSDATA> <DIMENSION Name="E1"> <MEMBERS> <MEMBER> <LABEL>[None]</LABEL> <AT Name="DefCurrency">[None]</AT> <DESCRIPTION Language="English">[None]</DESCRIPTION> </MEMBER> </MEMBERS> <HIERARCHY> <NODE> <PARENT>#root</PARENT> <CHILD>[None]</CHILD> </NODE> <NODE> <PARENT>#root</PARENT> <CHILD>MNG_CN</CHILD> </NODE> </HIERARCHY> </DIMENSION> <DIMENSION Name="Z1"> <HIERARCHY> <NODE> <PARENT>abc</PARENT> <CHILD>123</CHILD> </NODE> <NODE> <PARENT>def</PARENT> <CHILD>456</CHILD> </NODE> </HIERARCHY> </DIMENSION> </HSDATA>

  • EXCEL マクロ 

    お世話になります。 マクロは初心者です。 セルの数値を参照して、シートをアクティブにしたいのですが 下記のような繰り返しでシートが30ぐらいあるので、簡単な 表現に出来ないでしょうか。 宜しくお願いします。 Private Sub Workbook_Open() If 0 <= Worksheets(4).Range("M1") < 7 Then Worksheets(4).Activate End If If 0 <= Worksheets(5).Range("M1") < 7 Then Worksheets(5).Activate End If If 0 <= Worksheets(6).Range("M1") < 7 Then Worksheets(6).Activate End If If 0 <= Worksheets(7).Range("M1") < 7 Then Worksheets(7).Activate End If If 0 <= Worksheets(8).Range("M1") < 7 Then Worksheets(8).Activate End If If 0 <= Worksheets(9).Range("M1") < 7 Then Worksheets(9).Activate End If End Sub

  • エクセル マクロ

    よろしくお願いします。 エクセルのテキストに従って勉強していて コード抜けがないことも確認したのですが 「ifに対するend ifがありません」と表示されます。 デバックを開いてもブレークポイントが表示されていないので よくわかりません。 どこが問題かご享受ください。 Private Sub CommandOK_Click() Dim Row As Integer Row = Range("D1").Value + 3 If 会員登録画面.氏名カナ.Value = Empty Then MsgBox ("氏名カナが空欄です") Exit Sub End If If 会員登録画面.氏名漢字.Value = Empty Then MsgBox ("氏名漢字が空欄です") Exit Sub If Not IsDate(会員登録画面.年.Value & _ "/" & 会員登録画面.月.Value & _ "/" & 会員登録画面.日.Value) Then MsgBox ("生年月日の形式が正しくありません") Exit Sub End If Cells(Row, 1).Value = 会員登録画面.会員番号.Value Cells(Row, 2).Value = 会員登録画面.氏名カナ.Value Cells(Row, 3).Value = 会員登録画面.氏名漢字.Value If 会員登録画面.男.Value = True Then Cells(Row, 4).Value = "男" Else Cells(Row, 4).Value = "女" End If Cells(Row, 5).Value = DateValue(会員登録画面.年.Value & _ "/" & 会員登録画面.月.Value & _ "/" & 会員登録画面.日.Value) Cells(Row, 6).Value = 会員登録画面.都道府県.Value Cells(Row, 7).Value = 会員登録画面.電話番号.Value If 会員登録画面.スポーツ観戦.Value = True Then Cells(Row, 8).Value = "○" End If If 会員登録画面.映画鑑賞.Value = True Then Cells(Row, 9).Value = "○" End If If 会員登録画面.読書.Value = True Then Cells(Row, 10).Value = "○" End If If 会員登録画面.釣り.Value = True Then Cells(Row, 11).Value = "○" End If If 会員登録画面.ドライブ.Value = True Then Cells(Row, 12).Value = "○" End If If 会員登録画面.旅行.Value = True Then Cells(Row, 13).Value = "○" End If Range("D1").Value = Range("D1").Value + 1 Call 画面初期化 End Sub

  • VBScriptでXMLのデータを取得する方法

    こんにちは。 プログラミング初心者です。どうぞよろしくお願いします。 VBSで下記のようなXMLのtitleをpub idごとに別々に分けて抽出したいのですが、どうしたらよいか全く分からない状態です。 <book> <publisher> <pub id="集英社"/> </publisher> <title>ドラゴンボール</title> </book> <book> <publisher> <pub id="講談社"/> </publisher> <title>はじめの一歩</title> </book> <book> <publisher> <pub id="集英社"/> </publisher> <title>ジョジョの奇妙な冒険</title> </book> <book> <publisher> <pub id="秋田書店"/> </publisher> <title>範馬刃牙</title> </book> 下記のリンク先サイトにあったコードを試したのですが、titleが一緒くたに抽出されてしまい、別々に抽出ができません。pub idの階層が一つ深いのが原因だと思うのですが・・・どうしたらよいのか、さっぱり思いつきません。 http://www.atmarkit.co.jp/fxml/rensai/msxml01/msxml03.html Dim objDOM, rtResult Set objDOM = WScript.CreateObject("MSXML2.DOMDocument") rtResult = objDOM.load("○○.xml") If rtResult = True Then procDispDatas objDOM.childNodes End If Set objDOM = Nothing Sub procDispDatas(objNode) Dim obj For Each obj In objNode If obj.nodeType = 3 and obj.parentNode.nodeName = "title" Then MsgBox obj.parentNode.nodeName & " : " & obj.nodeValue End If If obj.hasChildNodes Then procDispDatas obj.childNodes End If Next End Sub どうかアドバイスをよろしくお願いいたします!

  • エクセル マクロ

    C15に="田中"&TEXT(A15,"m.d") C15に田中8.31と表示されてます 別のシート作成し 田中8.31 と名前を付けておきます C15を押した時に飛ぶように設定しようとしたのですが うまくいかないのですが どうしたらいいでしょうか? Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$C$14" Or Target.Address = "$C$15" Then Worksheets(Target.Value).Visible = True Worksheets(Target.Value).Select Else End If End Sub Worksheets(Target.Value).Visible = True ここの部分でうまくいかなくなります

  • エクセル マクロ 教えてください。

    sheet1に (a1=No. b1=月日 C1=項目 d1=収入 e1=支出 f1=摘要 G1=店名)項目を作りそれらをユーザーフォームを作り入力したいです。 この記述では上手く動けません。教えてください。 Private Sub CommandButton1_Click() Dim r As Long, 最終行 As Long, 項目行 As Long Dim re As String r = textboxs1.Value + 10 最終行 = Worksheets("入力").Range("B65536").End(xlUp).Row If r <= 最終行 Then re = MsgBox("訂正" & " " & "すでにデータが入力されています。" & Chr(13) & _ Chr(13) & "データを置き換えます。 本当に良いですか? ", _ Buttons:=vbYesNo + vbExclamation, Title:="注意!!") If re = vbYes Then With Worksheets("入力") .Cells(r, 2).Activate .Cells(r, 1).Value = TBox1.Value .Cells(r, 2).Value = TBox2.Value .Cells(r, 3).Value = ComboBox1.Value .Cells(r, 4).Value = TBox3.Value .Cells(r, 5).Value = TBox4.Value .Cells(r, 6).Value = TBox5.Value .Cells(r, 7).Value = ComboBox2.Value End With データクリア Exit Sub End If データクリア Exit Sub End If If r >= 最終行 + 1 Then r = 最終行 + 1 End If With Worksheets("入力") .Cells(r, 1).Value = TBox1.Value .Cells(r, 2).Value = TBox2.Value .Cells(r, 3).Value = ComboBox1.Value .Cells(r, 4).Value = TBox3.Value .Cells(r, 5).Value = TBox4.Value .Cells(r, 6).Value = TBox5.Value .Cells(r, 7).Value = CBomboox2.Value End With データクリア End Sub r = データNo + 10 With Worksheets("入力") .Activate .Cells(r, 2).Select TBox1.Value = .Cells(r, 1).Value TBox2.Value = .Cells(r, 2).Value ComboBox1.Value = .Cells(r, 3).Value TBox3.Value = Format(.Cells(r, 4).Value, "###,###") TBox4.Value = Format(.Cells(r, 5).Value, "###,###") TBox5.Value = .Cells(r, 6).Value ComboBox2.Value = .Cells(r, 7).Value End With Exit Sub End If If データNo > 最終行 - 10 Then データNo = 最終行 - 9 TBoxNo.Value = データNo データクリア End If End Sub

  • ExcelのマクロをAccessで動かすには…

    今までExcelを使用していてVBAも段々と理解してきたのですが 今回Accessを使用することになって詰まってしまいました。 下のようなExcelのマクロ(VBA)があるのですが、 これをAccessでも同じように動かしたいのですがわかりません(汗) ----------------------------------------------- Sub テスト() Dim GYO As Long GYO = 1 Do Until Worksheets("テスト").Cells(GYO, 1).Value = "" If Worksheets("テスト").Cells(GYO, 1).Value >= 80 Then Worksheets("テスト").Cells(GYO, 2).Value = "合格" Else Worksheets("テスト").Cells(GYO, 2).Value = "不合格" End If GYO = GYO + 1 Loop End Sub ----------------------------------------------- これでAccessのレコード一つ一つの合否を入力する欄に 自動で入力されるようにしたいのですが、 Accessでの記述方法がよくわからないのです。(^_^;) お詳しい方、よろしくお願いしますm(_ _)m

  • マクロで質問します。

    初心者です。 下記のようなマクロの式があるのですが、条件を一つ増やしたいのですが、 イロイロ試してみたのですが、うまくゆきませんので教えてください! Sub 給与支払一覧() Application.ScreenUpdating = False Dim Sh As Worksheet For Each Sh In Worksheets If Sh.Name <> "給与支払一覧" And Sh.Name Like "Sheet*" Then With Worksheets("給与支払一覧") If Sh.Range("D14").Value > 0 Then With .Cells(.Rows.Count, 1).End(xlUp).Offset(1) Sh.Range("O2:X14").Copy .Cells(1) .Resize(13, 10).Value = Sh.Range("O2:X14").Value End With End If End With End If Next Sh Set Sh = Nothing End Sub この中で If Sh.Range("D14").Value > 0 Then とありますが、 同じ条件で I14も 0より大きいな時としたいのですが、 うまくゆきませんでした。 たぶん基本できな簡単な事と思いますが 分かりません。 If Sh.Range("D14").Value > 0 Then If Sh.Range("I14").Value > 0 Then 並べてみたり If Sh.Range("D14、I14").Value > 0 Then こんなのや If Sh.Range("D14、I14").).Value > 0 Then このような事も 他にも笑われるようなことも・・・・・ よろしくお願いします。

  • エクセルマクロ実行時エラー1004について

    システムを起動すると実行時エラー1004とでて5行目のWorksheets(3).Selectで止まってしまいます。 私が作成したものではなく、なぜなのかわかりません。緊急を要しています。誰かわかる方いらっしゃらないでしょうか。 よろしくお願いします。 Dim Max_data2 As Integer Public Cunt_01 As Integer Sub auto_open() Dim wkSheet As Excel.Worksheet Worksheets(3).Select ' Range("c4") = Date ' Range("c20") = Date Range("d6").Select With Worksheets("工場、受注一覧表") ' Worksheets("工場、出荷指示書").Range("j3").Value = Date ' Worksheets("工場、出荷指示書").Range("I4").Value = Date ' Worksheets("工場、出荷指示書").Range("J4").Value = Time .Range("d5").Value = Date .Range("d21").Value = Date .Range("d23").Value = Date End With For Each wkSheet In ThisWorkbook.Worksheets If InStr(wkSheet.Name, "工場、出荷指示書") <> 0 Or InStr(wkSheet.Name, "@") <> 0 Then wkSheet.Range("J3").Value = Date wkSheet.Range("I4").Value = Date wkSheet.Range("J4").Value = Time End If Next Call com_list Cunt_01 = 10 '1件づつ転記のカウンタ '★追加★ '入出庫報告書のファイルを開く Dim sPath As String sPath = ThisWorkbook.Worksheets("工場、受注一覧表").Range("W1").Value If sPath = "" Then Exit Sub End If If Dir(sPath) <> "" Then Workbooks.Open (sPath) End If ThisWorkbook.Activate ''★23.06.12 ActiveWindow.SmallScroll ToRight:=4 End Sub

専門家に質問してみよう