| |
過去に作った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
|
|
![[未読]](./data/word/image/read_icon.gif){kind=icon}
