マクロでひとつ前のシートの名前を変更する方法

質問

エクセルのマクロにてシートの名前変更がうまく行かず困っています。
内容はsheetの名前が「2-1」「2-2」「2-2 (2)」「2-2 (3)」「2-2 (4)」だとします。
シート名に枝番があるsheetの中の文章をコピーし新しくBookを開きそこに貼り付けていく、というマクロを作成しました。
しかし「2-2」は枝番が無いので計算するsheetと認識されません。

Sheets("2-2").Name = "2-2 (1)"
にして出来ることは出来るのですが、デバックになりチェックし修正した後に、実行すると「2-2 (1)」に変更してしまったので、「2-2」なんてシートは無い！となりますよね？
そこで、また実行したい時は2-2シートの枝番を消して実行したり、エクセルを全部閉じてから実行していました。

そこで、もし「2-2」なら「2-2 (1)」にして、「2-2 (1)」がすでにあるなら名前はそのままにし、実行というマクロの作成方法を教えていただきたいです！

それと、「2-2 (2)」の前のシートを強制的に「2-2 (1)」にする。のようなマクロがあったらそれも教えて頂けたらうれしいです。お願いします！

回答No.4

myRange · ベストアンサー

>質問も初めてでしたので、不愉快な思いをさせて申し訳ありません

別に不愉快な思いをしているわけではありません。
処理の内容、シートレイアウトなどを提示した方が
何回も遣り取りする必要がない分、質問者、回答者とってベターですよ
と言いたかっただけです。

＞("B28:F35")の範囲がセルの結合がされており

これが一番重要なことです。
で、あれば先の回答の「貼り付けが被る」という疑問は解消します。
どうでしょう、これでレイアウトを提示することの重要さがわかったと思います。

で、回答サンプルコードは以下のようになります。

'---------------------------------------------------
Sub チェック2_2()
Dim Oldfile_name As String
Dim Newfile_name As String
Dim Checkfile_name As String
Dim Ws As Worksheet
Dim Rng As Range
Dim Kei_No As String
Dim i As Long
Dim R As Long

Application.ScreenUpdating = False

Workbooks("雛形.xls").Activate　'■本番では実際のブック名に変更

Oldfile_name = ActiveWorkbook.Name
Kei_No = Mid(Oldfile_name, 5, 10)

Workbooks.Add
ActiveWorkbook.SaveAs "C:\data2\temp\2-2チェック結果_" & Kei_No & ".xls"
Checkfile_name = ActiveWorkbook.Name
Sheets(1).Select

'＝＝雛形ブックからチェックブックのＢ列へ＝＝

For Each Ws In Workbooks(Oldfile_name).Worksheets
　If Ws.Name Like "2-2*" Then
　　　i = i + 1
　　　R = (i - 1) * 2 + 1
　　　Cells(R, 2).Value = Ws.Range("B28").Value
　　　Cells(R + 1, 2).Value = Ws.Range("I28").Value
　End If
Next Ws

'--全角、半角スペースと改行、タブコードなどの削除--
For Each Rng In Range(Cells(1, 2), Cells(i * 2, 2))
　　Rng.Value = Replace(Rng.Value, " ", "")
　　Rng.Value = Replace(Rng.Value, "　", "")
　　Rng.Value = WorksheetFunction.Clean(Rng.Value)
Next Rng

'＝＝業務用ソフトから吐き出されたブックから＝＝
'＝＝チェックブックのＣ列へ　　　　　　　　＝＝

　　i = 0

For Each Ws In Workbooks(Kei_No & ".xls").Worksheets
　　If Ws.Name Like "2-2*" Then
　　　　i = i + 1
　　　　R = (i - 1) * 2 + 1
　　　　Cells(R, 3).Value = Ws.Range("B28").Value
　　　　Cells(R + 1, 3).Value = Ws.Range("I28").Value
　　End If
Next Ws

'--全角、半角スペースと改行、タブコードなどの削除--
For Each Rng In Range(Cells(1, 3), Cells(i * 2, 3))
　　Rng.Value = Replace(Rng.Value, " ", "")
　　Rng.Value = Replace(Rng.Value, "　", "")
　　Rng.Value = WorksheetFunction.Clean(Rng.Value)
Next Rng

'----チェックブックのＢ列とＣ列を比較して結果をＤ列へ------

With Range(Cells(1, 4), Cells(i * 2, 4))
　　.FormulaR1C1 = "=EXACT(R[0]C[-2],R[0]C[-1])"
End With

Application.ScreenUpdating = True

End Sub
'-------------------------------------------------

●シート名、２－２を２－２（１）へ変換するルーチンは不必要です。
また、ＥＸＡＣＴ関数は、大文字と小文字を区別しますのでそのつもりで。

●ブックは、以下の４つです。
１．マクロブック（上記コードはこのブックへコピペ）
２．雛形ブック
３．業務用ソフトから吐き出されたブック
４．チェック結果ブック

一応軽くテストして動作を確認してあります。
以上ここまで。

お礼

お世話になっております。
作成していただいたコードを確認させていただいたところ、処理速度も今までと比べ物にならないほど早く全て完璧に実行され、思い描いたようなマクロでした。大変ありがとうございました。
　まだまだわからないところだらけなので、また質問させていただくかもしれませんが、その時はよろしくお願いいたします。勉強になりました。本当にありがとうございました。

回答No.3

myRange

最初の質問についてコードをアップした方がベターだと言ったのです
が、ま、それは置いといて。。

新しい質問のためのコードをアップするならするで、
どういうブックがあって、どういうことをやりたいのか
そういうことを何も書かずに、ただ、ホレッ、と投げてはいけません。
特に、提示のコードのように可読性の低いものは。

折角なのでちょと眺めてみました。

このコード、結果は別としてエラーなく動作してますか？
エラーが出るはずですが。
例えば、変数が宣言されてないとか、宣言されてる変数と違うものが使われてるとか。。
極めつけは、プロシージャ名。
いくらなんでも、Sub 2-2チェック()
こんな名前を付けたら、この行を確定した途端にエラーになるはずです。

よって、提示のコードは、実際のコードと同じものではない、と推測できます。

ま、それを除いても、ロジック自体におかしいところがあります。
その一部を取り上げてみます。

（●）
Range("B28:F35").Select
Selection.Copy

Windows(checkfile_name).Activate
Sheets(1).Cells(i * 2 - 1, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues

（▲）
Range("I28:M35").Select
Selection.Copy

Windows(checkfile_name).Activate
Cells(i * 2, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues

（　i=1　の時）
Range("B28:F35")を、Checkブックの Cells(1, 2)から貼り付け
Range("I28:M35")を、Checkブックの Cells(2, 2)から貼り付け

これだとどういうふうに貼り付けられるかというと

＿＿Ｂ＿Ｃ＿Ｄ＿Ｅ＿Ｆ＿
１＿B28,C28,D28,E28,F28　●上記
２＿I28,J28,K28,L28,M28　▲上記
・・・・・・・・・・・・▲
４＿I35,J35,K35,L35,M35　▲上記

と、●が貼り付けされたその一行下から▲が貼り付けられる
おかしいですよね。

質問者は貼り付けられたブックの内容をチェックしたのでしょうか。
どうもチェックしてないような。。。。

ま、それはそれとして、
このコードは一見しただけでおかしいところが多々見つかります。

コードを完成したいのなら、先にも言いましたように
■どんなブック、どんなシート、どんなセル範囲、などのレイアウト
■及び、どんな処理をしたいのか箇条書きにして提示するべきでしょう

補足

マクロ作成も初心者ですし、質問も初めてでしたので、不愉快な思いをさせて申し訳ありません。今後気をつけるようにいたします。
　確かにコードは変更させていただきました。コードをコピーしてワードパットに貼り付けて変更したためプロシージャ名変更による確認ができませんでした。指摘後にやってみたところ確定すらできませんでした。お恥ずかしい限りです。
　しかし会社情報などがわからないように変更しようとしただけで、変更したところといえば、プロシージャ名と、コードの後ろにそのコードの意味の補足（’で認識しない）を消すのと、新しい貼り付け先のBookの体裁コードを文字数縮小の為省いた。この３つでした。
　特に変数の宣言なので変えたところはなかったのですが、不思議なことにエラーが起きませんでした。それとご指摘がありましたが、２つのエクセルブックからコピーしてきた文章を貼り付けた新しいブックのチェックですが、チェックしましたが何でこんなおかしな形に貼り付けられるの？？など気になったところはなく、こうなったら比較しやすいな。という形にちゃんとなっていました。「myRange様」が書かれた事を読むと確かにおかしいな・・と思うんですが。

　あまりにも不透明な質問だったのでご指摘があったように、どのような内容かを掲載させていただきます。遅れまして申し訳ありません。
・ひな型のエクセルがあり、それに文字や画像を追加していくエクセルブックがエクセルAです。これを最終形として考えます。
・エクセルAを見ながらコピペや入力を業務用ソフトに追加して行き、それをエクセル出力したものがエクセルBです。
・エクセルA,Bともにシート名、シートの中身、セル範囲などまったく同じになります。
・枝番も含めシート2-2はすべて上に画像が挿入されており("B28:F35")の範囲がセルの結合がされており上の絵にたいする文章が入っています。1シートにつき絵と文章が左右に2つ入ります。
・エクセルBはエクセルAを見ながら手打ちしていったので、間違いがあると思われるので、エクセルAとエクセルBで文章があっているかを一目で確認できるようにするという確認マクロの作成でした。
・マクロを実行するときは、マクロが入っているBOOKとエクセルA、エクセルBを開きエクセルBで実行していました。

お願いいたします。

回答No.2

myRange

＞Sheets("2-2").Name = "2-2 (1)"にして出来ることは出来るのですが
＞デバックになりチェックし修正した後に、実行すると「2-2 (1)」に
＞変更してしまったので、「2-2」なんてシートは無い！となりますよね？

実際のコードが提示されてないので、上記のことちょと、ん？　ではありますが。。

'-----シート2-2 を　2-2(1)に変更 ----------
Sub Test()
　Dim myName As String
　myName = "2-2"

　On Error Resume Next
　　　Sheets(myName).Select
　　　If Err.Number = 0 Then
　　　　　Sheets(myName & " (2)").Select
　　　　　If Err.Number = 0 Then
　　　　　　　Sheets(myName).Name = myName & " (1)"
　　　　　End If
　　　End If
　On Error GoTo 0

'　　＊＊＊　ここから通常処理　＊＊＊

End Sub
'-----------------------------------------

見れば分かると思いますが、
シート２－２　と　シート２－２（２）をチェックしています。
これは、シート２－２　のみしかなかった場合には
シート２－２（１）を作成する必要がないので。

'-----シート2-2(2)の前のシートを　2-2(1)に変更-----
Sub Test33()
　Dim Idx As Integer
　Dim myName As String
　myName = "2-2"

　Idx = Sheets(myName & " (2)").Index
　Sheets(Idx - 1).Name = myName & " (1)"
End Sub
'-----------------------------------------------

質問者の現在のコードがアップされていると
より的確な回答が寄せられると思いますが。。。
以上ここまで。

補足

回答ありがとうございます。まだまだわからないことだらけで、「myRange様」から教えていただいた内容でもやってみます。
先ほど「Trick--o--様」から教えていただいたコ－ドでやってみたコードを載せさせていただきます。

新しい質問になってしまうのですが、2つのエクセルの比較Bookでまったく同じ文章が入っているのにFALSEになってしまいます。友人はラインフィードやキャリッジリータンが関係してると思うから（Chr10？Chr13？）、それを認識しないようにするコードじゃないとダメなのかな？といってましたが、何かわかりますか？お願いします。

Sub 2-2チェック()
'
'
Dim oldfile_name As String
Dim newfile_name As String
Dim chekfile_name As String
Dim kei_No As String

oldfile_name = ActiveWorkbook.Name
kei_No = Mid(oldfile_name, 5, 10)

Workbooks.Add
ChDir "C:\data2\temp"
ActiveWorkbook.SaveAs Filename:="C:\data2\temp\2-2チェック結果_" & kei_No & ".xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False

checkfile_name = ActiveWorkbook.Name
Windows(oldfile_name).Activate

Dim ws As Worksheet
Dim flag1 As Boolean, flag2 As Boolean
flag1 = False
flag2 = False
For Each ws In Worksheets
If ws.Name = "2-2" Then flag1 = True
If ws.Name = "2-2 (1)" Then flag2 = True
Next ws

If flag1 = True And flag2 = False Then
Sheets("2-2").Name = "2-2 (1)"
End If

For i = 1 To 7 '枝番が7個以上あった場合はここの数を変更する

Windows(oldfile_name).Activate
Sheets("2-2" & " (" & i & ")").Select
Range("B28:F35").Select
Selection.Copy

Windows(checkfile_name).Activate
Sheets(1).Cells(i * 2 - 1, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Windows(oldfile_name).Activate
Range("I28:M35").Select
Application.CutCopyMode = False
Selection.Copy

Windows(checkfile_name).Activate
Cells(i * 2, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next i

Windows(checkfile_name).Activate
Sheets(1).Range(Cells(1, 3), Cells((i - 1) * 2, 3)).FormulaR1C1 = "=SUBSTITUTE(R[0]C[-1],""　"","""")"

Windows(kei_No & ".xls").Activate
newfile_name = ActiveWorkbook.Name

'Dim ws As Worksheet
'Dim flag1 As Boolean, flag2 As Boolean
flag1 = False
flag2 = False
For Each ws In Worksheets
If ws.Name = "2-2" Then flag1 = True
If ws.Name = "2-2 (1)" Then flag2 = True
Next ws
If flag1 = True And flag2 = False Then
Sheets("2-2").Name = "2-2 (1)"
End If

For i = 1 To 7 '枝番が7個以上あった場合はここの数を変更する

Windows(newfile_name).Activate
Sheets("2-2" & " (" & i & ")").Select
Range("B28:F35").Select
Selection.Copy

Windows(checkfile_name).Activate
Sheets(1).Cells(i * 2 - 1, 4).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Windows(newfile_name).Activate
Range("I28:M35").Select
Application.CutCopyMode = False
Selection.Copy

Windows(checkfile_name).Activate
Cells(i * 2, 4).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Next i

Windows(checkfile_name).Activate
Sheets(1).Range(Cells(1, 5), Cells((i - 1) * 2, 5)).FormulaR1C1 = "=EXACT(R[0]C[-2],R[0]C[-1])"

End Sub

回答No.1

Trick--o--

プログラムは「言語」です。
日本語を翻訳しましょう。

もし「2-2」なら「2-2 (1)」にして、「2-2 (1)」がすでにあるなら名前はそのままにし、実行

・シート「2-2」「2-2 (1)」が存在するか？
→全てのシートの名前を確認して、一致するものがあるか？
Dim ws As Worksheet
Dim flag1 As Boolean , flag2 As Boolean
flag1 = False
flag2 = False
For Each ws In Worksheets
　　If ws.Name = "2-2" Then flag1 = True
　　If ws.Name = "2-2 (1)" Then flag2 = True
Next ws

・「2-2」があって「2-2 (1)」が無いときは名前を変更
If flag1 = True And flag2 = False Then
　　Sheets("2-2").Name = "2-2 (1)"
End If

あとはお望みの処理を実行。

コードの最適化等は次のステップで。

お礼

問題なく出来ました^^ありがとうございます！
当方初心者なので、教えていただいた

Dim ws As Worksheet
Dim flag1 As Boolean , flag2 As Boolean

を2回書き、「いや、既に宣言されてるよ」ってエラーが出てオロオロしてましたが（エクセルAとエクセルBの文章のコピーして新しいBookに貼り付けその2つの内容に間違いが無いか確認というマクロだったので2回書きました）、やっと理解して何回実行してもエラーが出てこなくなりました！
ありがとうございました！