[[20150827131206]] 『リストにある名前でファイルを複数保存したい』(どんべえ) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『リストにある名前でファイルを複数保存したい』(どんべえ)

こんにちは。
宜しくご教示願います。

EXCELのA列・B列にそれぞれお客様コードが入っています。
このお客様コードを使用したファイルの保存をマクロで行いたいのですが、
コードを教えて頂きたくお願い致します。

【c\:test\title.xls】
A列 B列
A0000 A1
B0000 B4
D0000 12



※行数は都度異なる

【c\:test\調査票.xls】

【c\:test\A0000_A1_調査票.xls】
【c\:test\B0000_B4_調査票.xls】
【c\:test\D0000_12_調査票.xls】
となる様にしたい。

※調査票自体は統一のフォーマットです。
※A列とB列の文字の後にアンダーバー”_”を入れたいですが、マクロに入れるのが難しい場合はセルに入れます。

よろしくお願い致します。

< 使用 Excel:Excel2010、使用 OS:Windows7 >


 直接の回答ではありませんが・・・。

 >※調査票自体は統一のフォーマットです。 

 同じフォーマットのブックを複数作成する理由はありますか?
 一つのブックにまとめておくことは出来ないのでしょうか?
(カリーニン) 2015/08/27(木) 13:28

カリーニン様

コメントありがとうございます。
出来上がったファイルを各お客様へ送付します。
メールシステムで一括送付する際、ファイル名で宛先を仕分けるため、
それぞれのお客様のコードが必要となっております。

どうぞよろしくお願い致します。
(どんべえ) 2015/08/27(木) 13:39


こんにちは

単純にコピーして変名するだけでも良さそうですよね?

Sub test()

    Dim r As Range
    Dim t As Range
    Dim i As Long
    Dim f As String
    Dim p As String

    p = "c:\test\"
    f = p & "調査票.xls"

    With ActiveSheet
        Set t = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
        i = t.Count
        For Each r In t
            FileCopy f, p & r.Value & "_" & r.Offset(, 1).Value & "_調査票.xls"
        Next
    End With
End Sub

(ウッシ) 2015/08/27(木) 13:57


 衝突しましたがそのままアップします。

 参考です。

 ブックのパスやフォルダ、シート名は実際のものに置き換えて実行してください。

Sub test()

 Dim listwb As Workbook
 Dim copywbpath As String
 Dim ws As Worksheet
 Dim r As Range
 Dim c As Range
 Dim fol As String
 Dim newwbpath As String
  fol = "c:\test"
  copywbpath = fol & "\調査票.xlsx"
  Set listwb = Workbooks.Open(fol & "\title.xlsx")
  Set ws = listwb.Worksheets("List")
  Set r = ws.Range(ws.Cells(1, 1), ws.Cells(Cells.Rows.Count, 1).End(xlUp))
  For Each c In r
   newwbpath = fol & "\" & c.Value & "_" & c.Offset(, 1).Value & "_" & Dir(copywbpath)
   If Dir(newwbpath) <> "" Then
      AppActivate Application.Caption
      MsgBox newwbpath & vbCrLf & "は既に存在するファイル名です。"
   Else
      FileCopy copywbpath, newwbpath
   End If
  Next c
  listwb.Close , False
  Set r = Nothing
  Set ws = Nothing
  Set listwb = Nothing
End Sub
(カリーニン) 2015/08/27(木) 14:05

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.