Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


15604 / 76738 ←次へ | 前へ→

【66610】名前が重複する場合に名前を変えたい
質問  アクア  - 10/9/13(月) 20:12 -

引用なし
パスワード
   C:\Practiceにあるすべてのエクセルブックのうち、2010から始まるシートだけを集約(新規ブックに順次コピー)して、コピー後のシートには元ブックの名前をつけようとプログラミングしました。

しかし、C:\Practiceにあるエクセルブックには、2010から始まるシートが複数枚存在するブックも存在することに気づきました。
そのため、「AAA.xls」のシートが「2010_a」、「2010_b」、「2009_c」、「2010_d」と3枚の2010から始まるシートがあったとき、
新規ブックには「2010_a」、「2010_b」、「2010_d」がくっつくのですが、「2010_a」をAAA.xlsというシート名、「2010_b」を
AAA.xls_2というシート名、「2010_b」をAAA.xls_3というシート名がふられるように決めました。
しかし、この添え字が順次ふられる部分をどう書いていいものか分からず困っています。
申し訳ありませんが、ご教授願えないでしょうか?
よろしくお願いいたします。


Option Explicit
Sub 集約()
 Dim PATH As String, MERGE_BOOKNAME As String
 Dim PATH_BOOK_NAME As String
 Dim INIT_SHEETS As Long, i As Long
 Dim MERGE_BOOK As Workbook
 Dim Sheet_No As Integer
 
 'パスとファイル名
 PATH = "C:\Practice"
 MERGE_BOOKNAME = "集約.xls"

 Set MERGE_BOOK = Workbooks.Add
 
 '最初から付いてくるシートを消すための前処理
 INIT_SHEETS = Worksheets.Count
 
 '全ブック名の取得
 PATH_BOOK_NAME = Dir(PATH & "*.xls")
  
 Do While PATH_BOOK_NAME <> ""
  'すべてのブックの先頭シートを新規ブックにコピー
  If PATH_BOOK_NAME <> MERGE_BOOKNAME Then
   With Workbooks.Open(PATH & PATH_BOOK_NAME)
    '立ち上げたブックの先頭シートを新規シートの末尾にコピー
    For Sheet_No = 1 To .Worksheets.Count
      '2010から始まる名前のシートをコピーする
      If Mid(.Worksheets(Sheet_No).Name, 1, 4) = "2010" Then
        .Worksheets(Sheet_No).Copy after:=MERGE_BOOK.Worksheets(MERGE_BOOK.Worksheets.Count)
      End If
    Next
    
    '追加したシートの名前を元のブック名とする
    MERGE_BOOK.Worksheets(MERGE_BOOK.Worksheets.Count).Name = .Name
   
    '立ち上げたブック(既存のフォルダ内)を保存せず閉じる
    .Close savechanges:=False
   End With
  End If
  PATH_BOOK_NAME = Dir()
 Loop
 
 
 '新規ブックに最初から付いていたシートをすべて消す 【★】と対応
  For i = 1 To INIT_SHEETS
   MERGE_BOOK.Worksheets(1).Delete
  Next

 '新規ブックを保存する
 MERGE_BOOK.SaveAs PATH & MERGE_BOOKNAME
 
 '変数MERGE_BOOKのクリア
 Set MERGE_BOOK = Nothing
End Sub

0 hits

【66610】名前が重複する場合に名前を変えたい アクア 10/9/13(月) 20:12 質問
【66611】Re:名前が重複する場合に名前を変えたい えり 10/9/13(月) 20:35 回答
【66612】Re:名前が重複する場合に名前を変えたい kanabun 10/9/13(月) 21:30 発言
【66613】Re:名前が重複する場合に名前を変えたい kanabun 10/9/13(月) 21:38 発言
【66614】Re:名前が重複する場合に名前を変えたい アクア 10/9/13(月) 21:50 お礼

15604 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free