Excel VBA質問箱 IV

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

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


2676 / 13645 ツリー ←次へ | 前へ→

【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 お礼[未読]

【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


【66611】Re:名前が重複する場合に名前を変えたい
回答  えり  - 10/9/13(月) 20:35 -

引用なし
パスワード
   (‘ -‘ )えりわかったわ!シート名をつける位置がよろしくないわ!

dim a

 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
       a = 1
      '2010から始まる名前のシートをコピーする
      If Mid(.Worksheets(Sheet_No).Name, 1, 4) = "2010" Then
        .Worksheets(Sheet_No).Copy after:=MERGE_BOOK.Worksheets(MERGE_BOOK.Worksheets.Count)
        
        If a = 1 Then
        MERGE_BOOK.Worksheets(MERGE_BOOK.Worksheets.Count).Name = .Name
        Else
        MERGE_BOOK.Worksheets(MERGE_BOOK.Worksheets.Count).Name = .Name & a
        End If
      
        a = a + 1
        
      End If
    Next


    '立ち上げたブック(既存のフォルダ内)を保存せず閉じる
    .Close savechanges:=False
   End With
  End If
  PATH_BOOK_NAME = Dir()
 Loop


(‘ -‘ )ためしてないから不具合がでたら自分で改編してちょうだい!

【66612】Re:名前が重複する場合に名前を変えたい
発言  kanabun  - 10/9/13(月) 21:30 -

引用なし
パスワード
   ▼アクア さん:

>「2010_a」をAAA.xlsというシート名、「2010_b」を
>AAA.xls_2というシート名、「2010_b」をAAA.xls_3というシート名がふられるように決めました。
>しかし、この添え字が順次ふられる部分をどう書いていいものか分からず困っています。

すでに問題点の開示がありますが、
サンプルコードを書いてみたので、参考にしてください。

ただし、下のコードは AAA.xls の
「2010_a」を【AAA】というシート名、
「2010_b」を【AAA_2】というシート名、
「2010_c」を【AAA_3】というシート名にしています。


Sub 集約2()
 Dim myPath    As String
 Dim MergeBOOK  As Workbook
 Dim mergeBOOKname As String
 Dim opnBOOK   As Workbook
 Dim bookName  As String
 Dim sheetName  As String
 Dim nSheet   As Long
 Dim wsheet   As Worksheet
 Dim i      As Long
 
 'パスとファイル名
 myPath = "E:\(Data)\TempBook\" '\Practice"
 mergeBOOKname = "集約.xls"
 Set MergeBOOK = Workbooks.Add(xlWBATWorksheet) 'シート1枚のBook

 'PATH内全ブックの取得
 bookName = Dir$(myPath & "*.xls")
 
 Do While bookName <> ""
  'すべてのブックの先頭シートを新規ブックにコピー
  If bookName <> mergeBOOKname Then
   Set opnBOOK = Workbooks.Open(myPath & bookName)
   With MergeBOOK.Worksheets
    sheetName = Replace(LCase$(opnBOOK.Name), ".xls", "")
    nSheet = 0
    For Each wsheet In opnBOOK.Worksheets
      If wsheet.Name Like "2010*" Then
        '2010から始まる名前のシートをコピーする
        wsheet.Copy After:=.Item(.Count)
        '◆追加したシートの名前を元のブック名+連番とする
        nSheet = nSheet + 1
        .Item(.Count).Name = _
           Replace(sheetName, vbTab, "_" & nSheet)
        If InStr(sheetName, vbTab) = 0 Then
          sheetName = sheetName & vbTab
        End If
      End If
    Next
    opnBOOK.Close SaveChanges:=False
   End With
  End If
  bookName = Dir$()
 Loop

 Application.DisplayAlerts = 0
 MergeBOOK.Worksheets(1).Delete
 Application.DisplayAlerts = True

 '新規ブックを保存する
 With MergeBOOK
   .SaveAs myPath & mergeBOOKname
   If MsgBox("閉じますか?", vbOKCancel, mergeBOOKname) = vbOK Then
    .Close
   End If
 End With
End Sub

【66613】Re:名前が重複する場合に名前を変えたい
発言  kanabun  - 10/9/13(月) 21:38 -

引用なし
パスワード
   すみません
↑の

> Do While bookName <> ""
>  'すべてのブックの先頭シートを新規ブックにコピー

のところ

 Do While Len(bookName) > 0

だけにしてください。
(つまり、2行目のコメントは 実体と異なるので 削除です)

【66614】Re:名前が重複する場合に名前を変えたい
お礼  アクア  - 10/9/13(月) 21:50 -

引用なし
パスワード
   ▼えり さん
▼kanabun さん

回答ありがとうございます。
私にとっては非常に高度なプログラムを提示いただいたので
今から頑張って解読し、習得したいと思います。
この度は突然の質問にもかかわらず、丁寧に回答いただき
ありがとうございました。
助かりました。

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