[[20100301163618]]　『シートのコピー＆削除とシート名の取得』（ｋｎ）　ページの最後に飛ぶ

『シートのコピー＆削除とシート名の取得』（ｋｎ）

元となるシート（Ａ）をコピーし、シートを増やした時と、
使用済みシートを削除した時にブック内のシート名を取得し、
任意の列に表示をさせたいのですが、マクロをどう組んだらいいか分かりません。

 Sub ボタン1_Click()
   Dim vntSheetName As Variant
   Dim WS1 As Worksheet
   Dim WS2 As Worksheet
   Dim lngRow As Long
   vntSheetName = ""
   Do While vntSheetName = ""
      vntSheetName = Application.InputBox("追加シート名を入力して下さい。", "シート追加", Type:=2)
      If VarType(vntSheetName) = vbBoolean Then
         MsgBox "キャンセルしました"
         Exit Do
      Else
         If wsexist(ThisWorkbook, vntSheetName) Then
            MsgBox vntSheetName & "　：　このシート名は既に存在します。違うシート名を指定してください"
            vntSheetName = ""
         End If
      End If
   Loop
   If Not VarType(vntSheetName) = vbBoolean Then
      Sheets("週報").Copy After:=Worksheets(Sheets.Count)
      Set WS1 = Worksheets("in")
      Set WS2 = ActiveSheet
      WS2.Name = vntSheetName
      lngRow = WS1.Range("A" & WS1.Rows.Count).End(xlUp).Offset(1).Row
      WS1.Cells(lngRow, 1).Value = vntSheetName
      WS2.Activate
   End If
 End Sub
 '========================================================================
 Function wsexist(ByVal bk As Workbook, ByVal shtnm As String) As Boolean
    'wsexist true   指定のシート名は存在する
    '         false 指定のシート名は存在しない
    On Error Resume Next
    Err.Clear
    Dim wk As Object
    Set wk = bk.Sheets(shtnm)
    wsexist = Not CBool(Err.Number)
    On Error GoTo 0
 End Function

Sub ボタン2_Click()

    Dim sn As String, ws As Worksheet
    sn = Application.InputBox("削除シート名を入力して下さい。", "シート削除", Type:=2)
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(sn)
    On Error GoTo 0
    If ws Is Nothing Then
        MsgBox "該当のシートはありません！"
        Exit Sub
    End If
    If Not ThisWorkbook.Sheets.Count > 1 Then
        MsgBox "これ以上シートは削除できません！"
        Exit Sub
    End If
    Application.DisplayAlerts = False
    ws.Delete
    Application.DisplayAlerts = True

    Call sheetsname
End Sub

Sub sheetsname()

    Columns("q:q").ClearContents

    For i = 3 To Worksheets.Count
      Cells(i, 17).Value = Worksheets(i).Name
    Next

    ActiveSheet.Range("q1:q2").Delete (xlShiftUp)

End Sub

現在このようなマクロを色んな所からコピーして製作している途中です。

シートは例として

in（名前や電話番号などのリストのあるシート）
Ａ（コピーをする様式のあるシート。inより情報を検索します）
"１"
"２"
.
.
.

と増やしていき、不要になれば

"１"
"３"
"６"
.
.
.
などと規則性なく削除します。

現在行き詰まっていることは、
・任意の列にシート名を表示させること
・in、Ａをシート名のリストには入れないようにする。
・シートを削除した時に自動でそのリストを更新する。
・はたしてこのマクロは正しいのか（マクロ初心者のためよくわからないのです）

ひとまずこの４つです。

OSはXP、バージョンは2003です。

宜しくお願い致します。

 質問は
 >はたしてこのマクロは正しいのか
 という事でしたら、望んだ結果が得られるのであれば正しいのではないでしょうか？

 ツッコミどころがあるかというと
 >Sub ボタン1_Click()
 の
 >Exit Do
 は、Exit Subにすると後で出てくる
 >If Not VarType(vntSheetName) = vbBoolean Then
 の判定は要らなくなるかな？とか

 >Sub sheetsname() 
 の
 >For i = 3 To Worksheets.Count
 >   Cells(i, 17).Value = Worksheets(i).Name
 >Next
 で、3からループさせているのに後から
 >ActiveSheet.Range("q1:q2").Delete (xlShiftUp)
 と、2行削除しているのは何故だろう？

 なんていう疑問が出てきたりしますが。。。
 （ｍｏｍｏ）

 ご返答ありがとうございます。

 >Sub ボタン1_Click()
 の
 >Exit Do
 は、Exit Subにすると後で出てくる
 >If Not VarType(vntSheetName) = vbBoolean Then
 の判定は要らなくなるかな？

 これはココの他の書き込みを参考に作らせて頂いているため、あまり理解していないまま作成しているのです。
 必要ないのであれば削除して試してみます。

 >For i = 3 To Worksheets.Count
 >   Cells(i, 17).Value = Worksheets(i).Name
 >Next
 で、3からループさせているのに後から
 >ActiveSheet.Range("q1:q2").Delete (xlShiftUp)
 と、2行削除しているのは何故だろう？

 これは
 ・in
 ・Ａ
 のシート以外のシート名をQ列に表示させようと組んだのですが、いまいち思うように出来なくて未完成の状態になっているのです。

 「シート名を取得」というマクロを組むとアクティブシートのA1セルにシート名が表示され、Q列にどうしても入りませんでした。
 どうにかQ列に表示させる事は出来ませんでしょうか？

 ｍｏｍｏさんすみません、質問の趣旨をはき違えていたようです。

 >For i = 3 To Worksheets.Count
 >   Cells(i, 17).Value = Worksheets(i).Name
 >Next
 で、3からループさせているのに後から
 >ActiveSheet.Range("q1:q2").Delete (xlShiftUp)
 と、2行削除しているのは何故だろう？
　
 これですが、必要なシート名だけ（in、Ａ以外）を取得しようとすると、
 Q3セルから表示されるようになってしまったので、空白となるQ1、Q2セルを削除しようと考えたのです。

 他に何かいい方法はありませんでしょうか？

 外出してまして返事が送れてすみませんでした

 >他に何かいい方法はありませんでしょうか？

 >Cells(i, 17).Value = Worksheets(i).Name
 を
 Cells(i - 2, 17).Value = Worksheets(i).Name
 とするだけでも出来るとは思いますが・・・

 でも、後々色々問題が出そうですので・・・

 私がやるとしたら配列変数に順番に格納しておいて
 一気に該当セルに出力します。
 シートのｉｎとＡを省くのも、必ずシートインデックスが１と２に居るとは
 限らないと思うので、全てのシートをループしてIfで条件分岐させて取得します。
 以下がサンプルコードですので試してみてください。

  Sub sheetsname()
  Dim ws As Worksheet, wsName() As String, i As Long
  Columns("Q").ClearContents
  ReDim wsName(1 To Worksheets.Count - 2, 1 To 1)
  For Each ws In Worksheets
    If ws.Name <> "in" And ws.Name <> "Ａ" Then
      i = i + 1
      wsName(i, 1) = ws.Name
    End If
  Next ws
  Range("Q1").Resize(UBound(wsName)).Value = wsName
  End Sub

 お返事有り難うございます。
 書き込みが大変遅れてしまって申し訳ありません。

 サンプルコードを試してみましたが、

 wsName(i, 1) = ws.Name

 ここでエラーが出てしまい、私には直せませんでした。

 "実行時エラー　9"
 "インデックスが有効範囲内にありません"

 というような内容です。

 （ｋｎ）

 「in」、「Ａ」というシートは必ず存在するのでしょうか？
 (独覚)

 独覚様、お返事有り難うございます。

 ここでは「Ａ」としていますが、
 実際には「週報」というシートでして、「ｉｎ」と合わせてこの２つは必ず存在します。

（ｋｎ）

   If ws.Name <> "in" And ws.Name <> "Ａ" Then
 ここでシート名が除外するシート名であるかどうかをチェックしているようなので、比較しているシート名が
 全角・半角も含めて実際のものと同じかどうか確認してみてください。
 (独覚)

 独覚さんフォローありがとうございます。
 全角半角含みのチェックと（inが半角Ａが全角になっていたかな？）
 あとは試すときのシートがｉｎとＡが無い状態でしたら数が合わないのでエラーになります。
 （ｍｏｍｏ）

 独覚さん、ｍｏｍｏさんありがとうございました。
 ここまでの問題は解決されました。

 もう一つのマクロの問題がまだ残っているのですが、宜しければお付き合い願えませんでしょうか？

 Sub ボタン1_Click()
   Dim vntSheetName As Variant
   Dim WS1 As Worksheet
   Dim WS2 As Worksheet
   Dim lngRow As Long
   vntSheetName = ""
   Do While vntSheetName = ""
      vntSheetName = Application.InputBox("追加シート名を入力して下さい。", "シート追加", Type:=2)
      If VarType(vntSheetName) = vbBoolean Then
         MsgBox "キャンセルしました"
         Exit Do
      Else
         If wsexist(ThisWorkbook, vntSheetName) Then
            MsgBox vntSheetName & "　：　このシート名は既に存在します。違うシート名を指定してください"
            vntSheetName = ""
         End If
      End If
   Loop
   If Not VarType(vntSheetName) = vbBoolean Then
      Sheets("週報").Copy After:=Worksheets(Sheets.Count)
      Set WS1 = Worksheets("in")
      Set WS2 = ActiveSheet
      WS2.Name = vntSheetName
      lngRow = WS1.Range("A" & WS1.Rows.Count).End(xlUp).Offset(1).Row
      WS1.Cells(lngRow, 1).Value = vntSheetName
      WS2.Activate
   End If
 End Sub
 '========================================================================
 Function wsexist(ByVal bk As Workbook, ByVal shtnm As String) As Boolean
    'wsexist true   指定のシート名は存在する
    '         false 指定のシート名は存在しない
    On Error Resume Next
    Err.Clear
    Dim wk As Object
    Set wk = bk.Sheets(shtnm)
    wsexist = Not CBool(Err.Number)
    On Error GoTo 0
 End Function

 これを実行した際、新しく追加したシートが"ｉｎ"のA列に表示されるんですが、
 ・シートを追加→シートのリストを更新（"ｉｎ"、"Ａ"を抜いて）→Q列に表示
 としたいのです。

 前回までの質問と同じような内容で大変申し訳ないのですが、宜しくお願い致します。

 追記です。
 WS1.Cells(lngRow, 1).Value = vntSheetName
 を
 WS1.Cells(lngRow, 17).Value = vntSheetName
 にすることでQ列へ表示する事は出来たんですが、
 既存のシート名リストに追加したシート名を増やすようになっていて、
 その追加したシートがリスト最後尾ではなく途中に表示されてしまいます。

 例）

 Q列          →　シート「6」を追加　→　　　Q列
 1　　　　　　　　　　　　　　　　　　　　　 1　　　
 2                                           2
 3                                           3 
 4                                           6
 5                                           5

 こんな感じに追加したシート（6）が途中に入ってしまい、それまであった「4」が消えてしまいます。

 ・シートを追加→リストに新しく追加したシート名を加える→Q列に表示
 ではなく、
 ・シートを追加→リストをもう一度取得→Q列に表示
 としたいのです。

 （ｋｎ）

 一寸良く分かってないかもしれませんが
 その部分で「sheetsname」を実行(Call)すれば良いのでは？

 (HANA)

コメント返信：

[ 一覧(最新更新順) ]

[[20100301163618]] 『シートのコピー＆削除とシート名の取得』（ｋｎ） ページの最後に飛ぶ

[[20100301163618]]　『シートのコピー＆削除とシート名の取得』（ｋｎ）　ページの最後に飛ぶ