エクセルのシート名を、シート１に作成した新旧一覧表に対応させる形で、複数シート一括で変更するには？

質問

エクセルのシート名の変更について教えてください。

シート１のＡ列に、現在のブックのシート名が、
シート１のＢ列には、変更したいシート名が
対応するように入力されています。
シート数は50～200程度で、つど変わります。

例
　　　　Ａ列　　　　Ｂ列
１行目：りんご　　　赤色　
２行目：ばなな　　　黄色
３行目：メロン　　　緑色
　　　　・　　　　　・
　　　　・　　　　　・
　　　　・　　　　　・

※この場合、「りんご」は「赤色」に、「ばなな」は「黄色」に、
「メロン」は「緑色」に、それぞれシート名を変換したい。

今は、手作業でひとつずつシート名を変換しており、
かなりの手間で困っています。
一覧表を作成するまでは手作業でいいのですが、
何とかして、シート名の変更を、この一覧表を参照して
できないでしょうか？
過去の質問をいろいろと見たのですが、
該当するものが見つけられず、ＶＢＡも初心者のため、
途方にくれています。
ぜひともご教授ください。

回答No.2

zap35 · ベストアンサー

マクロサンプルです。マクロは標準モジュールシートに貼り付けてください。変換表のシート名は４行目を修正のこと。

Sub Macro1()
Dim sh As Worksheet
Dim res
Const trg As String = "Sheet1"　'シート１のシート名に変更
For Each sh In Worksheets
　　Set res = Worksheets(trg).Range("A:A").Find( _
　　　　what:=sh.Name, LookIn:=xlValues, Lookat:=xlWhole)
　　If Not res Is Nothing Then
　　　　sh.Name = res.Offset(0, 1).Value
　　End If
Next sh
End Sub

お礼

早々にありがとうございます。
これならば、Ａ列とＢ列で、列単位で対応できるのですね。
質問文には書いていなかったのですが、
そのほうが都合がよく、使わせてもらいました。
本当に助かりました。
ありがとうございました！

回答No.1

Masa2072

サンプルです参考にしてください。

Sub ChaneSheetName（）
'カレントブックのSheet1!A1をカレントセルに
ThisWorkbook.Sheets("Sheet1").Range("A1").Select

'カレントセルの値が空白になるまで処理を繰り返す
Do Until Selection.Value = ""
'カレントセルと同じ名前のシート名をB列の値に変更
Sheets(Selection.Value).Name = Selection.Cells(1, 2).Value
'一つ下のセルをカレントセルに
Selection.Cells(2, 1).Select
Loop
End Sub

エラー処理等は書いてませんのでご注意を

お礼

早々にありがとうございます。
思いのとおりに動きました。
目からうろこがぽろぽろです。
助かりました！
ありがとうございました！