FrontPage 新規 編集 検索 一覧 ヘルプ

BBS-雑談/9

テキストファイルからエクセルファイルへ - のぶこ (2003年09月26日 12時04分19秒)

サンプルデータではちゃんと動きました。

  1)既存のエクセルファイルに書き足すようにしたい。
   →今は新規に更新されてしまいます。
  2)既存のエクセルファイルに仕込んであるマクロを 
   1シート書き込み後に実行したい。
  3)入力ファイルには空行も存在する。

可能でしょうか?

1)既存のエクセルファイルに書き足すようにしたい。

 Set objWB = objExcel.Workbooks.Open(OUTPUT_XLS)

2)既存のエクセルファイルに仕込んであるマクロを1シート書き込み後に実行したい。

 objWB.Application.Run MACRO ' MACROはマクロ名の文字列指定

3)入力ファイルには空行も存在する。

空行を飛ばせばいいでしょうか。

 ElseIf Trim(strLine) <> "" Then      ' シート名でなければ・・・

上記は、空行なら何もしないです。

先ほどのサンプルに上記の修正を適用しました。

マクロ入りのエクセルデータも含むサンプル >> text2xls2.lzh

 Option Explicit
 ' text2xls2.vbs - テキストファイルからエクセルファイルへ
 ' 2003/09/26 by tuka.
 'On Error Resume Next
 
 ' リテラル・設定など
 Const INPUT_TEXT = "input.txt"
 Const OUTPUT_XLS = "output.xls"
 Const MACRO      = "PrintMSG"
 
 ' テキストファイル読み込み用
 Dim objFS, objText
 Set objFS = CreateObject("Scripting.FileSystemObject")
 Set objText = objFS.OpenTextFile(INPUT_TEXT)
 
 ' エクセルオートメーション用
 Dim objExcel, objWB, objWS
 Set objExcel = CreateObject("Excel.Application")
 ' 新規にブックを作成
 'Set objWB = objExcel.Workbooks.Add
 ' 既存のマクロ入りブックを取得
 Set objWB = objExcel.Workbooks.Open(OUTPUT_XLS)
 
 ' 正規表現用(シート名取得用)
 Dim objRE
 Set objRE = New RegExp
 objRE.Pattern = "^sheet_\d+$"        ' シート名パターン
 
 Dim strLine, arrData
 Dim iRow, iCol
 iRow = 0
 While Not objText.AtEndOfStream
     strLine = objText.ReadLine           ' 一行読み込み
     If objRE.Test(strLine) Then          ' シート名なら・・・
         If iRow Then
             objWB.Application.Run MACRO  ' マクロ起動
         End If
         Set objWS = objWB.Sheets.Add         ' ワークシート追加
         objWS.Name = strLine                 ' シート名設定
         iRow = 1                             ' 行を先頭にセット
     ElseIf Trim(strLine) <> "" Then      ' シート名でなければ・・・
         arrData = Split(strLine, ",")        ' データ取得
         For iCol = 1 To UBound(arrData) + 1  ' フィールド数ループ
             objWS.Cells(iRow, iCol) = arrData(iCol - 1)
         Next
         iRow = iRow + 1
     End If
 Wend
 objWB.Application.Run MACRO ' マクロ起動
 
 ' 作成したブックをセーブ
 'objWB.SaveAs OUTPUT_XLS
 objWB.Close True
 
 ' インスタンス廃棄
 Set objWS = Nothing
 Set objWB = Nothing
 Set objRE = Nothing
 Set objText = Nothing
 Set objFS = Nothing
 Set objExcel = Nothing
 
 ' 終了メッセージ
 WScript.Echo "作成しました!"

{{comment}}

Yesterday Today Total