同じ文字列を抽出して新規シート作成

質問

A列～E列までデータが入力されています。
E列は所々、空白セルがあります。
1行目は見出しです。

元データのA列の中で同じ文字列を探して
見出しと該当するA～E列の行を新規シートとして作成。
その際、シート名はA列の文字列。

A列の文字列が２つ以上見つからなくても
A列の文字列を新規シートにする。

最終行は常に変動します。

元データ　(B列～E列は割愛)
A-1
名前
A-2
鈴木
A-3
佐藤
A-4
鈴木
A-5
山田
A-6
佐藤

新規シート名 「鈴木」
A-1
名前
A-2
鈴木
A-3鈴木

新規シート名　「佐藤」
A-1
名前
A-2
佐藤
A-3
佐藤

新規シート名　「山田」
A-1
名前
A-2
山田

上記の事をマクロで実行させたいです。
ご指南の程、宜しくお願い致します。
エクセル2013

回答No.1

tom04 · ベストアンサー

こんばんは！

一例です。
元データはSheet1にあり、Sheet1の1行目は項目行で
データは2行目以降にあるとします。
標準モジュールです。

Sub Sample1()
Dim i As Long, k As Long, lastRow As Long, cnt As Long, str As String
Dim wS As Worksheet, wS2 As Worksheet, myFlg As Boolean
Application.ScreenUpdating = False
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wS = Worksheets(Worksheets.Count)
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").Insert
.Range("A1") = .Name
With Range(.Cells(2, "A"), .Cells(lastRow, "A"))
.Formula = "=IF(ISNUMBER(FIND(""-"",ASC(B2))),B3,B2)"
.Value = .Value
End With
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
wS.Range("A:A").Replace what:="名前", replacement:="", lookat:=xlWhole
wS.Range("A:A").SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS.Cells(i, "A"), Operator:=xlOr, Criteria2:="名前"
For k = 2 To Worksheets.Count
If Worksheets(k).Name = wS.Cells(i, "A") Then
myFlg = True
Exit For
End If
Next k
If myFlg = False Then
str = wS.Cells(i, "A")
Worksheets.Add after:=Worksheets(wS.Cells(i - 1, "A").Text)
ActiveSheet.Name = wS.Cells(i, "A")
End If
Set wS2 = Worksheets(wS.Cells(i, "A").Text)
wS2.Cells.Clear
Range(.Cells(1, "B"), .Cells(lastRow, "F")).SpecialCells(xlCellTypeVisible).Copy _
wS2.Range("A1")
For k = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
If InStr(StrConv(wS2.Cells(k, "A"), vbNarrow), "-") > 0 Then
cnt = cnt + 1
wS2.Cells(k, "A") = "A-" & cnt
End If
Next k
myFlg = False
cnt = 0
Next i
.AutoFilterMode = False
.Range("A:A").Delete
Application.DisplayAlerts = False
wS.Delete
Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
End Sub

じっくり考えればもっと簡単になるかもしれませんが、
とりあえずはこの程度で・・・m(_ _)m

お礼

返事が遅くなりました。
無事、解決しました。
ありがとうございました。