Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Professional : Excel 2010)
シート追加で同じ名前の時に連番をつける方法
投稿日時: 20/05/25 10:24:12
投稿者: ふしぎちゃん

お世話になります。
 
シート追加のマクロを作ろうとして
下記の構文を作成しました。
 
 
Sub シート追加()
 
Dim todayDate As String
  
ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
todayDate = Format(Date, "yyyymmdd")
ActiveSheet.Name = todayDate & "見積"
 
End Sub
 
ただ、同じ名前の時には、年月日見積(2)、年月日見積(3)
と出るようにしたいです。
 
一応、できているのですが
実行するたびに
エラーが出るので、
エラーを無視する方法以外で
実行するには、どのようにすればよろしいでしょうか?
 
エラー内容は、
「実行時エラー'1004’
 シートの名前を他のシート、Visual Basicで参照されるオブジェクトライブラリまたは
 ワークシートと同じ名前に変更することはできません。」
 
よろしくお願いします。

回答
投稿日時: 20/05/25 13:35:54
投稿者: WinArrow
投稿者のウェブサイトに移動

エラーを無視することはできたとしても、
シート名は、手で変更するのでしょうか?
 
事前に最終のシート名を変数に記憶しておけばよいと思います。
 

回答
投稿日時: 20/05/25 13:51:25
投稿者: WinArrow
投稿者のウェブサイトに移動

代案
 
ミリ秒まで取得して、
yyyymmdd_hhmmssttt
というような形式にすると
一意のシート名になるかな??
 
 
Timer関数 ミリ秒
で検索すると参考になるページがあります。

投稿日時: 20/05/25 13:52:00
投稿者: ふしぎちゃん

WinArrowさん
有難うございます。
 
いろんな人が活用するデータです。
ちゃんと管理する人は
手で変更する人はすると思いますが
 
そのままシートをコピーして
後から確認できにくい管理の人もいると思うので
あえて、見積した日だけでも自動的に
名前がつくようにしようと考えております。
 

回答
投稿日時: 20/05/25 14:27:39
投稿者: WinArrow
投稿者のウェブサイトに移動

シート名を取得するユーザー定義関数を提案します。
 
↓を標準モジュールにコピペします。
 
 
Function MaxSHEETNAME()
Dim ShtName As String
Dim stx As Long, Nx As Long
 
    ShtName = ""
    With ThisWorkbook
        For stx = 1 To .Worksheets.Count
            If .Sheets(stx).Name Like Format(Date, "yyyymmdd") & "*" Then
                If .Sheets(stx).Name > ShtName Then
                    ShtName = .Sheets(stx).Name
                End If
            End If
        Next
    End With
     
    If ShtName <> "" Then
        If InStr(ShtName, "(") > 0 Then
            Nx = Val(Mid$(ShtName, InStr(ShtName, "(" + 1)))
        End If
        Nx = Nx + 1
        MaxSHEETNAME = Left$(ShtName, InStr(ShtName & "(", "(") - 1) & " (" & Nx & ")"
    Else
        MaxSHEETNAME = Format(Date, "yyyymmdd") & "見積"
    End If
 
 
End Function
 
>todayDate = Format(Date, "yyyymmdd")
>ActiveSheet.Name = todayDate & "見積"
の2行を↓のように変更します。
todayDate = MaxSHEETNAME
ActiveSheet.Name = todayDate
 
試してみてください。
 
但し、カッコつきシート名の最初は「(2)」ではなく、「(1)」です。
 

投稿日時: 20/05/25 14:44:11
投稿者: ふしぎちゃん

WinArrowさん
本当に有難うございます。
 
1回目での実行はできて、
同じ日に2回目を実行すると
 
型が一致しません。
と出て、
Nx = Val(Mid$(ShtName, InStr(ShtName, "(" + 1)))の
所が指摘されています。
 
すみません。
教えてください。

回答
投稿日時: 20/05/25 16:15:45
投稿者: WinArrow
投稿者のウェブサイトに移動

>Nx = Val(Mid$(ShtName, InStr(ShtName, "(" + 1)))
コードが間違っていました。
 修正したはずでしたが・・・申し訳ありません。
  
Nx = Val(Mid$(ShtName, InStr(ShtName & "(", "(" + 1)))
 

投稿日時: 20/05/25 20:21:30
投稿者: ふしぎちゃん

WinArrow さん
本当に有難うございます。
 
教えて頂いた内容に変更しても
同じエラーがでます。
 
私の何かの方法が間違っているのでしょうか?
 
標準モジュールに
Function MaxSHEETNAME()
Dim ShtName As String
Dim stx As Long
Dim Nx As Long
  
    ShtName = ""
    With ThisWorkbook
        For stx = 1 To .Worksheets.Count
            If .Sheets(stx).Name Like Format(Date, "yyyymmdd") & "*" Then
                If .Sheets(stx).Name > ShtName Then
                    ShtName = .Sheets(stx).Name
                End If
            End If
        Next
    End With
      
    If ShtName <> "" Then
        If InStr(ShtName, "(") > 0 Then
           Nx = Val(Mid$(ShtName, InStr(ShtName & "(", "(" + 1)))
        End If
        Nx = Nx + 1
        MaxSHEETNAME = Left$(ShtName, InStr(ShtName & "(", "(") - 1) & " (" & Nx & ")"
    Else
        MaxSHEETNAME = Format(Date, "yyyymmdd") & "見積"
    End If
   
End Function
を貼り付けて
 
Sub シート追加()
 
Dim todayDate As String
  
ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
todayDate = MaxSHEETNAME
ActiveSheet.Name = todayDate
 
End Sub
 
を実行しています。
 
よろしくお願いします。
 

回答
投稿日時: 20/05/25 21:02:26
投稿者: たらのり

こんばんは
 
# かなり飲んでます
 
手元に Windows がないので直に入力しています。
「年月日見積」の後方の括弧の全半角や,空白文字の有無は
調整してください。
 
# うまくゆかなかったらごめんなさい
 

pulic sub 時そば()
    Dim todayDate As String
  
    ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
    todayDate = Format(Date, "yyyymmdd")
    ActiveSheet.Name = いま何どきだい(activesheet.parent, todayDate & "見積")
end sub

private function いま何どきだい(byval wb as excel.workbook, _
                              byval baseName as string) as string

    dim sh  as excel.worksheet
    dim i   as long

    dim shName  as string

    i = 1
    いま何どきだい = ""
    do
        shName = baseName & iif(i > 1, "(" & cstr(i) & ")", "")

        on error resume next
        set sh = wb.sheets(shName)
        if (err.number <> 0) then       ' shName が既存のとき == 0
            いま何どきだい = shName
        endif
        on error goto 0
        i = i + 1
    loop while (len(いま何どきだい) = 0)
end function

回答
投稿日時: 20/05/25 21:10:21
投稿者: WinArrow
投稿者のウェブサイトに移動

>todayDate = MaxSHEETNAME
の行を
.Copyの前の行に移動してください。
 

回答
投稿日時: 20/05/26 09:25:49
投稿者: mattuwan44

>エラーを無視する方法以外で
 
On Errorステートメントを使ったサンプルなぞ。
 

Sub シート追加2()
    Dim sSName As String: sSName = Format(Date, "yyyymmdd") & "_見積"
    Dim sNum As String: sNum = ""
    Dim ix As Long: ix = 2
    
    With Worksheets
        ActiveSheet.Copy After:=.Item(.Count)
        On Error GoTo ErrHandler
        .Item(.Count).Name = sSName & sNum
        On Error GoTo 0
    End With
    
    Exit Sub
    
ErrHandler:
    sNum = " (" & ix & ")"
    ix = ix + 1
    Resume
End Sub

 
とりあえず名前を変更してみて、エラーならGotoで例外処理に飛ぶ
例外処理では数をカウントして後ろの括弧を生成して戻る。
 
コツとしてはResume Next と、無視して次の行へ行かず、
エラーがでなくなるまでトライし続けるようにする。
無限ループに陥る可能性があるけど、今回は考慮しなくていいかな。。。。
 
ただコピーして名前変えるだけだけど、
それまでの前提条件や例外処理など、
余分なことをたくさん書かないといけない、
プログラムのいい例ですね^^

投稿日時: 20/05/26 13:00:02
投稿者: ふしぎちゃん

WinArrowさん、たらのりさん、mattuwan44さん
 
本当に有難うございます。
 
WinArrowさんの
>todayDate = MaxSHEETNAME
の行を
.Copyの前の行に移動してください。
をすると、(1)まではいけたのですが、
(2)以降ができませんでした。
 
たらのりさんは
ちょっと知識が追いつかないので
少し、時間が必要です。
 
mattuwan44さんの構文は
上手くいきましたが、動きが理解できていないので
もう少し、中身を見る時間をください。
 
簡単に考えていましたが、私の知識では
ハードルが高すぎるということがよくわかりました。
 
勉強したいので、もう少しこのままでいさせてください。

回答
投稿日時: 20/05/26 13:47:07
投稿者: たらのり

こんにちは
 
Excel で自分のコードを実行してみると,
まったく期待したとおりに動作しませんでした。
 
新しいシートの追加でなく,アクティブな
シートのコピーであることを見落としていました。
 
# 不具合の原因はそれだけではありませんが
 
大変失礼いたしました。m(_ _)m
 

回答
投稿日時: 20/05/26 18:39:44
投稿者: MMYS

シート名の重複は認められません。
だったら、前もって重複のないシート名を用意すれば良いですね。
シート名はループで分かります。
アルゴリズムは次の通り。
 
 新しく付ける名前を用意。
 重複あるか調べる
 重複なら番号をつけ、再度重複を調べる。
 
 

Sub CopyNewSheet()
    Dim strBase         As String
    Dim lngNumber       As Long
    Dim strSubscripts   As String
    Dim strNewSheet     As String
              
    strBase = Format(Date, "yyyymmdd") & "見積"
    lngNumber = 0
    strSubscripts = ""
    Do While IsExists(strBase & strSubscripts)  'シートの存在をチェック
        lngNumber = lngNumber + 1               '重複防止
        strSubscripts = " (" & lngNumber & ")"  '番号を付加する
    Loop
    strNewSheet = strBase & strSubscripts       '新しいシート名
    
    ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = strNewSheet
    
End Sub


Function IsExists(strSheetName As String) As Boolean
    Dim sh      As Worksheet
    Dim result  As Boolean
  
    result = False
    For Each sh In Worksheets
        result = result Or (sh.Name = strSheetName) '一致したらTrue
    Next
    
    IsSheetExists = result
End Function


 
シート数が増えると遅くなります。Dictionaryオブジェクトを使えば解決しますが、
今回は、理解のしやすさを優先しました。
 

投稿日時: 20/05/27 07:52:51
投稿者: ふしぎちゃん

MMYS さん
有難うございます。
 
説明もいれてくださり、
大変勉強になります。
 
実行してみると
シートはできているのですが
実行時エラー:1004
シートの名前を他のシート、Visual Basicで参照されるオブジェクトライブラリまたは
ワークシートと同じ名前に変更することはできません。
とでます。
 
デバックをすると
最後の
ActiveSheet.Name = strNewSheet
の所が指摘されます。

回答
投稿日時: 20/05/27 10:26:39
投稿者: simple

モジュールの先頭に
Option Explicit
と書くことを強く推奨します。
 
ちょっとしたコードの入力ミスと思いますが、
IsSheetExists = result

IsExists = result
とするか、いずれにせよ、プロシージャ名と平仄の取れたものにしてください。
Option Explicitが書かれていれば、
IsSheetExistsを未定義の変数として警告が出るはずです。
この件については、
http://officetanaka.net/excel/vba/beginner/06.htm
を参考にしてください。
 
また、

ツール − オプション − 編集 で
「変数の宣言を強制する」にチェックを入れてください。
モジュールを作成した時点で、Option Explicitが自動的に挿入されるので、
手間が省けます。
一度だけチェックを入れておきさえすれば、以後、気にする必要はありません。
↑重要です。

投稿日時: 20/05/27 12:44:36
投稿者: ふしぎちゃん

simple さん
 
有難うございます。
 
IsSheetExists = result

IsExists = result
とすることで、解決いたしました。
 
Option Explicit の件
勉強させて頂きます。
 
本当に皆さん、有難うございました。
一旦、閉めさせて頂きます。
 
特に、WinArrowさん
最後までアドバイスを頂いて
心より感謝いたします。
 
これからも、頑張って勉強します。
有難うございました。