エクセルのVBAを教えて下さい

質問

エクセルのVBAについて質問させて頂きます。

あるブックを、指定した20～30個のリストのタイトルをそれぞれにつけて20～30個複製し、さらにその複製したブックの指定したセルにタイトルと 同じ指定したリストの文字列を入れることは可能でしょうか。

説明が下手くそで申し訳ありません。

たとえば、Aというタイトルのブックを、
１から100のタイトルをそれぞれつけて100個複製し、
このブックのシート１のセルB1にブックのタイトルを入れるというような感じなのですが…(汗)

どなたか知恵をお貸しいただけると幸いです。

回答No.3

eden3616 · ベストアンサー

新規ブックを作成し、Sheet1のA列に1行目から作成したいタイトルのリストを間を開けずに作成してください。（添付画像を参照願います）
（ファイル名になりますので、拡張子「.xls」や「.xlsx」なども含め、他のタイトルと重複しないように）
Alt+F11でVBEを開き、挿入から標準モジュールを挿入してください。
下記のVBAコードを貼り付けて、右上の「×」でVBEを閉じてください。
Alt+F8よりマクロ「sample」を実行後、ファイルを開くダイアログが出ますので元のブック（ご提示の例ではAブック）を参照してください。

リストの数だけ、AブックのSheet1のセルB1にリストの名前を入力し、同名で別名保存します。
出力先は参照したAブックと同じフォルダになります。

また、仕様変更・要望等あれば補足願います。

■VBAコード
Sub sample()
Dim fpath As String
Dim myBook As Workbook
Dim myDir As String
Dim i As Long
fpath = Application.GetOpenFilename("全てのファイル(*.*),*.*")
Set myBook = Workbooks.Open(Filename:=fpath)
myDir = Left(myBook.FullName, Len(myBook.FullName) - Len(Dir(myBook.FullName)))
With ThisWorkbook.Sheets(1)
For i = 1 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　Application.StatusBar = .Cells(i, "A").Value & "を作成中"
　　　　myBook.Sheets(1).Range("B1").Value = .Cells(i, "A").Value
　　　　myBook.SaveAs Filename:=myDir & .Cells(i, "A").Value
　　　　DoEvents
Next i
myBook.Close
End With
End Sub

お礼

ありがとうございます！
早速試してみます！！！

回答No.4

chie65535

＞このブックのシート１のセルB1にブックのタイトルを入れる

「タイトル」が何なのか判りませんが「ファイル名」だと仮定すると、B1セルに

=MID(CELL("filename",A1),FIND("[",CELL("filename",A1))+1,FIND("]",CELL("filename",A1))-FIND("[",CELL("filename",A1))-1)

と言う式を入れておくと、自動的に「そのブックのファイル名」がB1に表示されます。

お礼

わかりにくい質問で申し訳ありません(汗)

ご回答ありがとうございます！
試してみます！

回答No.2

kagakusuki

>あるブック

と言われただけでは、質問者様以外の人間にはどの様なブックの事なのかさっぱり解りませんし、

>指定した20～30個のリストのタイトル

とは、どこのどこからどこまでの範囲に、どの様な形で指定されているのか、という事も説明して頂かなくてはVBAを組む事が出来ませんので、それらの点に関しても御説明願います。
　それから、そのリストに入力されているタイトルの中に、もしファイル名として使用できない文字列が存在していた場合や、同じタイトルが複数存在していた場合などにはどの様な扱いをすれば宜しいのでしょうか？

お礼

わかりにくい質問で申し訳ありません(汗)

VBAの知識が全く無いため、
そういった情報も必要なことをはじめて知りました。
ご指摘ありがとうございます！

回答No.1

FEX2053

テストもしてないので、その辺は別途確認してほしいのですが。

とりあえず、Title(100)の配列にタイトル名が1～100まで入ってるとするなら

For I=1 TO 100
Workbooks.Add
Range("B1").Value=Title(I)
ActiveWorkbook.SaveAs Filename:=Titel(I)
ActiveWorkbook.Close
Next

これで、セルB1にタイトル名が入った、タイトル名のブックが100個、
元のブックのあるフォルダにできるはずです。

お礼

ありがとうございます！

試してみます！！