| |
H. C. Shinopyさん
ありがとうございます。
プログラムを直接乗っけていただいたのでCSVを分解していくところなどかなり参考にさせていただきました。
今回はワードの雛形ファイルを作成してそこにブックマークを埋め込んでいき、
ブックマークに値を挿入する方法でできそうな感じがしてきております。
文字列を置換するところをブックマークに文字列を挿入に変えて何とか実現できる見通しが立ちました！
ありがとうございます！！
▼H. C. Shinopy さん：
>過去に作った2つのマクロをつないで作りました。
>CSVファイルの保存先（myFolder）・ファイル名（myFile）と、
>項目数（myColMax）・検索文字列（myFindText）は、
>そちらの状況に合わせて、変更する必要があります。
>
>やり方については、コメント行に書き込んだ通りです。
>「ワードの特定の部分に当てはめていく」件ですが、
>どうやってカーソルをそこに移動させるのか判らないので、
>一般的な手段として、文字列「@住所」「@あて先」「@日付」を検索して、
>全部置換すると考えました。
>まずは、回答まで。
>
>CSVデータは下のようなものと想定しています。
>保存先：「マイドキュメント」の「Zzz」フォルダ
>ファイル名：「zzz.csv」
>項目数：3
>1件目が、見出し行のデータ
>
>住所,あて先,日付
>aaa,bbb,ccc
>kkk,lll,mmm
>xxx,yyy,zzz
>
>Sub MyCsvToArr()
> Rem *----*----* *----*----* *----*----* *----*----*
> Rem 注記...
> Rem [元の文書]を開いた状態で実行する。
> Rem [元の文書]の「@住所」「@あて先」「@日付」を検索して置換する。
> Rem *----*----* *----*----* *----*----* *----*----*
> Rem CSV=>表処理
> Rem *----*----* *----*----* *----*----* *----*----*
> '
> Dim myShell As Variant ' IWshShell3
> Dim myFso As Variant
> Dim myFile As Variant
> '
> Dim myFolder As String
> Dim myFullName As String
> Dim myText As String
> Dim myLine As Variant
> '
> Dim i As Long
> Dim c As Long
> Dim myLineMax As Long
> Dim myColMax As Long
> '
> Dim myTitle As String
> Dim myStatusBar As String
> Dim myMsg As String
> Rem *----*----* *----*----* *----*----* *----*----*
> '
> myTitle = "myCsvToArr"
> myColMax = 3 ' 項目数 "@住所,@あて先,@日付"
> Rem *----*----* *----*----* *----*----* *----*----*
> '
> Set myShell = CreateObject("WScript.Shell")
> Set myFso = CreateObject("Scripting.FileSystemObject")
> Rem *----*----* *----*----* *----*----* *----*----*
> '
> Rem CSVファイルの保存先フォルダ・ファイル（指定要）｡
> myFolder = myShell.Specialfolders("MyDocuments") ' マイドキュメント
> myFolder = myFolder & "\Zzz"
> myFile = "\zzz.csv"
> myFullName = myFolder & "\" & myFile
> Rem *----*----* *----*----* *----*----* *----*----*
> '
> With myFso.OpenTextFile(myFullName, 8)
> myLineMax = .Line
> .Close
> End With
> '
> ReDim MyArray(myLineMax - 1, myColMax - 1)
> Rem *----*----* *----*----* *----*----* *----*----*
> '
> Set myFile = myFso.OpenTextFile(myFullName, 1)
> '
> c = 0
> Do Until myFile.AtEndOfStream
> myText = myFile.ReadLine
> myLine = Split(myText, ",")
> If (UBound(myLine) + 1) <> myColMax Then
> MsgBox "項目数異常：" & c + 1 & "件目"
> Exit Sub
> End If
> '
> For i = 0 To UBound(myLine)
> MyArray(c, i) = myLine(i) ' 置換文字列を配列に保存。
> Next ' i
> c = c + 1
> '
> myStatusBar = myTitle & "：処理中" & " " & Format(c, "###0") & "/" & myLineMax & "件"
> Application.StatusBar = myStatusBar
> Loop
> '
> myFile.Close
> Rem *----*----* *----*----* *----*----* *----*----*
> '
> beep
> myStatusBar = myTitle & "：CSVデータの読み込み完了！ "
> Application.StatusBar = myStatusBar & "総数：" & c & "件"
> '
> Rem *----*----* *----*----* *----*----* *----*----*
> '
> Set myShell = Nothing
> Set myFso = Nothing
> Set myFile = Nothing
> ' Set MyArray = Nothing
>' End Sub ' MyCsvToArr *----*----* *----*----* *----*----* *----*----*
>' ここから上は、あすか様の上司が作ったマクロ？私の想像。
>'
>' Sub MyNewDocuments()
> Rem *----*----* *----*----* *----*----* *----*----*
> Rem 検索置換・新規文書作成処理
> Rem *----*----* *----*----* *----*----* *----*----*
> '
> Dim myDocOne As String
> Dim myDocNew As String
> Dim myFindText As String
> Dim myFind As Variant
> '
> ' 検索する文字列を指定。
> myFindText = "@住所,@あて先,@日付"
> myFind = Split(myFindText, ",")
> ' 元の文書の保存先・ファイル名を取得。
> myDocOne = ActiveDocument.FullName
> ' 元の文書を閉じる。
> ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
> '
> ' [元の文書]のファイル名から「.doc」を削って新規文書ファイル名を準備。
> myDocNew = Replace(myDocOne, ".doc", "")
> '
> ' 作成する文書の数だけ繰り返し。（1件目は見出し行と見なす）
> For c = 1 To UBound(MyArray)
> ' 文書の新規作成。
> Documents.Add
> ' 新規文書に[元の文書]を挿入。
> Selection.InsertFile FileName:=myDocOne, Range:="", _
> ConfirmConversions:=False, Link:=False, Attachment:=False
> ' 新規文書の先頭にカーソルを戻す。
> Selection.HomeKey Unit:=wdStory, Extend:=wdMove
> '
> For i = 0 To myColMax - 1 ' 項目数だけ繰り返し。
> ' 一括検索置換。
> With Selection.Find
> .ClearFormatting
> .Replacement.ClearFormatting
> .Text = myFind(i)
> .Replacement.Text = MyArray(c, i)
> .Forward = True
> .Wrap = wdFindContinue
> .Format = False
> .MatchCase = False
> .MatchWholeWord = False
> .MatchByte = False
> .MatchAllWordForms = False
> .MatchSoundsLike = False
> .MatchWildcards = False
> .MatchFuzzy = True
> .Execute Replace:=wdReplaceAll
> End With
> ' 新規文書の先頭にカーソルを戻す。
> Selection.HomeKey Unit:=wdStory, Extend:=wdMove
> Next ' i
> ' 新規文書ファイル名に「4桁連番c.doc」を指定して保存。
> ActiveDocument.SaveAs FileName:=myDocNew & Format(c, "0000") & ".doc"
> ' 文書を閉じる｡
> ActiveDocument.Close
> Next ' c
> '
> beep
>End Sub
|
|
あすか
- 06/10/11(水) 13:03 -
![[未読]](./data/word/image/read_icon.gif){kind=icon}
