[[20121119154726]]　『データ差込して個別にファイル保存』　ページの最後に飛ぶ

 『データ差込して個別にファイル保存』

 エクセルで1つのシートに数十件～数百件の顧客データがあります。
 顧客ID毎に別シートで用意したテンプレートにデータ差し込みし、個別にファイル保存させたい。

 元データ.xls　　｢顧客｣シート
 B2(顧客ID：2345)  C2  D2  E2  F2  G2  H2
 B3(顧客ID：1111)  C3  D3  E3  F3  G3  H3
 B4(顧客ID：2356)  C4  D4  E4  F4  G4  H4
 B5(顧客ID：9076)  C5  D5  E5  F5  G5  H5
 .
 .
 .

↓

 元データ.xls　　｢作成｣シート
 D1 ・・・>　　｢顧客｣シートのB列
 F4 ・・・>　　｢顧客｣シートのC列
 H6 ・・・>　　｢顧客｣シートのD列
 K9 ・・・>　　｢顧客｣シートのE列
 K10 ・・・>　｢顧客｣シートのF列
 M2 ・・・>　　｢顧客｣シートのG列
 N6 ・・・>　　｢顧客｣シートのH列

 完成ファイル
 顧客ID：2345.xls
  D1 ・・・>　　｢顧客」シートのB2
  F4 ・・・>　　｢顧客｣シートのC2
  H6 ・・・>　　｢顧客｣シートのD2
  K9 ・・・>　　｢顧客｣シートのE2
  K10 ・・・>　｢顧客｣シートのF2
  M2 ・・・>　　｢顧客｣シートのG2
  N6 ・・・>　　｢顧客｣シートのH2

 顧客ID：1111.xls
  D1 ・・・>　　｢顧客｣シートのB3
  F4 ・・・>　　｢顧客｣シートのC3
  H6 ・・・>　　｢顧客｣シートのD3
  K9 ・・・>　　｢顧客｣シートのE3
  K10 ・・・>　｢顧客｣シートのF3
  M2 ・・・>　　｢顧客｣シートのG3
  N6 ・・・>　　｢顧客｣シートのH3

 顧客ID：2356.xls
  D1 ・・・>　　｢顧客｣シートのB4
  F4 ・・・>　　｢顧客｣シートのC4
  H6 ・・・>　　｢顧客｣シートのD4
  K9 ・・・>　　｢顧客｣シートのE4
  K10 ・・・>　｢顧客｣シートのF4
  M2 ・・・>　「顧客｣シートのG4
  N6 ・・・>　　｢顧客｣シートのH4

 顧客ID：9076.xls
  D1 ・・・>　　｢顧客」シートのB5
  F4 ・・・>　　｢顧客｣シートのC5
  H6 ・・・>　　｢顧客｣シートのD5
  K9 ・・・>　　｢顧客｣シートのE5
  K10 ・・・>　「顧客｣シートのF5
  M2 ・・・>　　｢顧客｣シートのG5
  N6 ・・・>　　｢顧客｣シートのH5

 可能でしょうか。

 WindowsVista, Excel2003
 （saya）

こんばんは

こんな感じでしょうか？

 Sub test()
    Dim r   As Range
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = Worksheets("顧客")
    Set sh2 = Worksheets("作成")
    Application.ScreenUpdating = False
    With sh1
        For Each r In .Range("B2", .Cells(Rows.Count, 2).End(xlUp))
            sh2.Range("D1").Value = r.EntireRow.Cells(1, "B")
            sh2.Range("F4").Value = r.EntireRow.Cells(1, "C")
            sh2.Range("H6").Value = r.EntireRow.Cells(1, "D")
            sh2.Range("K9").Value = r.EntireRow.Cells(1, "E")
            sh2.Range("K10").Value = r.EntireRow.Cells(1, "F")
            sh2.Range("M2").Value = r.EntireRow.Cells(1, "G")
            sh2.Range("N6").Value = r.EntireRow.Cells(1, "H")
            sh2.Copy
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & r.Value & ".xls", FileFormat:=xlNormal
            ActiveWorkbook.Close
        Next
    End With
    Set sh1 = Nothing: Set sh2 = Nothing
    Application.ScreenUpdating = True
End Sub

普通、・・・> の向きは逆です。
値を代入する方向を示さないと分かりにくいです。
（ウッシ）

 （ウッシ）さん

 ありがとうございます。
 まさに目的のものです。
 ただ、マクロを実行すると、｢既にこのロケーションにファイルが存在します。Replaceしますか？｣
 とメッセージが何度も出ます。それを全てYESで進むとちゃんとファイルは作成されていますが。
 何でしょうか？

 →の向き、失礼しました。。

 （saya）

こんにちは

 ThisWorkbook.Path にファイルが作成されます。
同じ場所に2345.xls等が作成されていると上書きされます。
アラートを出さないようにも出来ますけど、本来上書きしていいのでしょうか？
（ウッシ）

 （ウッシ）さん

 それが同じファイルがないのにメッセージが出るのです。
 つまり、新しいフォルダの中にこのツールを入れて、初めてマクロを実行して出てきてしまいます。
 アラートは出てくれた方がいいんですけど。。

 （saya）

こんにちは

そうですか？
今こちら（XP、2003）で試しましたけど、アラート出ないです。
なんででしょうね。
二度実行するとアラート出ますけど、
｢既にこのロケーションにファイルが存在します。Replaceしますか？｣
とは文言が違います。

「このロケelでは聞いたことのです

            On Error Resume Next
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & r.Value & ".xls", FileFormat:=xlNormal
            On Error GoTo 0
            ActiveWorkbook.Close False

としてエラーを回避するか、事前に同じファイルの有無を確認して別名で保存するとか色々な方法があります。
（ウッシ）

 (ウッシ)さん

 私の会社は外資系でPCも英語版なのでメッセージも普通の日本語のとは異なるのです。
 失礼しました。

 メッセージが出る原因が分かりました。顧客シートのB列に顧客IDを入れていますが、C列にも同じ顧客IDを入れていました。
 それで聞いてきたようです。（コード全部書いてもらって内容理解していないせいですね･･･）
さささ
 これで問題ありません。
 あとは私が色々調整すればいいだけです。

 本当にありがとうございました！！

 （saya）

  (ウッシ)さん

 データ差し込みする｢作成｣シートと一緒にその後ろに差し込みに関係のない3シートを（作成シートに連携した計算式が入っている）
 一緒にくっつけて個別にファイル保存しないといけなくなりました。

 元データ.xlsのシート構成
 ｢顧客｣シート・・・差し込みする元データのあるシート
 ｢作成｣シート・・・差し込み先のシート　※1
 ｢1回目｣シート・・・差し込みに関係ないシート（作成シートとリンクした計算式が入っている）　※2
 ｢2回目｣シート・・・差し込みに関係ないシート（作成シートとリンクした計算式が入っている）　※3
 ｢3回目｣シート・・・差し込みに関係ないシート（作成シートとリンクした計算式が入っている）　※4

 個別ファイル保存には※1～4が必要

 あと、個別ファイル名も下記としたいと。
 管理表_B2セル(顧客ID：2345)_C2セル(セル内容).xls
 ※B2とC2はセル内容を引っ張ってくる。

 どうかお願いします。

 (saya)

こんにちは

"1回目", "2回目", "3回目"というシート名、実際のシート名と合っているか確認して実行してみて下さい。

 Sub test1()
    Dim r   As Range
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim v
    Set sh1 = Worksheets("顧客")
    Set sh2 = Worksheets("作成")
    v = Array(sh2.Name, "1回目", "2回目", "3回目")
    Application.ScreenUpdating = False
    With sh1
        For Each r In .Range("B2", .Cells(Rows.Count, 2).End(xlUp))
            sh2.Range("D1").Value = r.EntireRow.Cells(1, "B")
            sh2.Range("F4").Value = r.EntireRow.Cells(1, "C")
            sh2.Range("H6").Value = r.EntireRow.Cells(1, "D")
            sh2.Range("K9").Value = r.EntireRow.Cells(1, "E")
            sh2.Range("K10").Value = r.EntireRow.Cells(1, "F")
            sh2.Range("M2").Value = r.EntireRow.Cells(1, "G")
            sh2.Range("N6").Value = r.EntireRow.Cells(1, "H")
            Worksheets(v).Copy
            ActiveWorkbook.SaveAs ThisWorkbook.Path & _
                "\管理表_" & r.Value & "_" & r(1, 2).Value & ".xls", _
                    FileFormat:=xlNormal
            ActiveWorkbook.Close
        Next
    End With
    Set sh1 = Nothing: Set sh2 = Nothing
    Application.ScreenUpdating = True
End Sub

作成シートとリンクした計算式がどんな式かによって保存された｢作成｣シート・・・差し込み先のシートを参照するか
どうかが多分決まります。
（ウッシ）

 （ウッシ）さん

 確認しました。
 リンクの計算式も問題ありませんでした。
 何度もお手数おかけしてすみませんでした。

 （saya）

コメント返信：

[ 一覧(最新更新順) ]

[[20121119154726]] 『データ差込して個別にファイル保存』 ページの最後に飛ぶ

[[20121119154726]]　『データ差込して個別にファイル保存』　ページの最後に飛ぶ