Excel ：シート名を複数のセルから取得して追加するには？

質問

宜しくお願いします。
"Sheet1"に２～３千行（列は10程度）あるデータを、20程度あるＡ列のデータをキーとして、そのキーをシート名としてシートを追加した後で層別して貼り付けたいのです。

第一段階の、キーになるデータの抽出から重複したキーの削除までは進められましたが、必要なキーの数だけシートを追加する事までは出来るのですが、シート名を変更（あるいは指定）しながら追加して
行く段階でどうしても上手く行きません。

　方法としては以下の二つ考えられるますが、実際にはどちらの考え方が良いのかも分からず、立ち往生しています。　必要な数のシートを追加するまでは、何とか辿り着いたので、この峠を越える力を与えて頂きたくお願い致します。

追加の考え方（但し、正しいのかは分かりませんが）
１．取得したキーとなる値("na")をシート名として追加する。または
２．全て追加した後でシート名をキーとなる値("na")に変更する。
※可能だと思われるので、出来れば１の様にシート名を変更しながら追加して行く方法に進みたい。

現在の到達点（これより以前は省略します）

Sub sheet()
' Dim na As strig
Sheets("Sheet3").Select
owari = Range("A1").CurrentRegion.End(xlDown).Row

For G = 2 To owari
'【シート名を指定して追加する場合はここ】
na = Range("A" & G).Value
ActiveWorkbook.Worksheets.Add
'【追加したシート名を変更する場合はここ】
Next G

End Sub

以上宜しくお願い致します。

回答No.1

onlyrom · ベストアンサー

重複したキー云々はあまり関係ありませね。
もちろんやり方によっては重要となりますが。

方法はいくつもありますがシンプルなコードを提示します。

新しいブックのSheet1にテストデータをいれ以下のコードを実行してください。

（条件）
データシート：　Sheet1
データ見出行：　１行目
データ開始行：　２行目～～
データ列＿＿：　Ａ～Ｋ列（最後の列Ｋ列は適当に）
データキー列：　Ａ列

'--------------------------------------------
Sub Test()
　Dim mySheet As Worksheet
　Dim NewSheet As Worksheet
　Dim myRange As Range
　Dim myKey
　Dim R As Long
　Dim StartRow As Long
　Dim EndRow As Long

　Application.ScreenUpdating = False

　Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)
　Set mySheet = ActiveSheet
　Set myRange = mySheet.Range("A1").CurrentRegion
　myRange.Sort Key1:=mySheet.Range("A2"), Order1:=xlAscending, _
　Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
　Orientation:=xlTopToBottom, SortMethod:=xlPinYin

　StartRow = 2

　With mySheet
　　For R = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　If .Cells(R, "A").Value <> .Cells(R + 1, "A").Value Then
　　　　　myKey = .Cells(R, "A").Value
　　　　　Set NewSheet = Sheets.Add(After:=Sheets(Sheets.Count))
　　　　　NewSheet.Name = myKey
　　　　　EndRow = R
　　　　　.Range(.Cells(StartRow, "A"), .Cells(EndRow, "K")).Copy NewSheet.Range("A2")
　　　　　.Rows(1).Copy NewSheet.Range("A1")
　　　　　StartRow = R + 1
　　　End If
　　Next R
End With

　Application.DisplayAlerts = False
　　　mySheet.Delete
　Application.DisplayAlerts = True
　Application.ScreenUpdating = True
End Sub
'---------------------------------------------------

見れば分かると思いますが、
先ず、データシートSheet1を丸ごとコピーして新しいシートを作成し、それを使って作業をします。
作業が終わったら、そのコピーしたシートは削除する。
以上。

お礼

大変助かりました。パーフェクトにやりたい事が出来ました。
当然のことですが、やはりツギハギで作っている物とは大違いですね。

まだ、いろんなパーツを拾い集めてはくっつけて動かす程度の事しか出来ないため、教えて頂いた
中身も完全には理解できていませんが、凄く良いお手本を頂けましたので一つひとつを紐解いて、
今後の参考にさせて頂き、いつの日か自力で完成出来るように頑張ろうと思います。　
本当に有難うございました。