Excel VBA質問箱 IV

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

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


15602 / 76738 ←次へ | 前へ→

【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
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 お礼

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