Sheet1(元データ/画像①)を 下記のコードにて、各シートごとに抽出・仕分けを行わせていただいていますが 以下、【A】【B】の2つのことを行えればと考えております。 【A】 画像②のようにシート名のうしろに 例えば「_数字」といった形で、抽出・仕分けされた件数を表示させることは可能でしょうか。 (シート内の行数=件数) 【B】 あと、これらを実行した後に(別の”Sub 抽出2()”の作業として) 抽出・仕分けした3桁のシートはそのままで、2桁のシートのみを削除するマクロ、VBAを実行してみたいと思っております。 (【A】のみでも大丈夫です) 恐れ入りますが、ご教示の程 何卒お願いいたします。 ※こちらに 画像①のSheet1(元データ)を保管いたしました。 https://119.gigafile.nu/1207-bc557722175a0b693acb2957dc29d0ef1 ---------- Sub 抽出1() Dim dic As Object Dim sh1 As Worksheet, sh2 As Worksheet Dim hh As Double Dim r As Long Dim dkey As Variant Dim wr As Variant Application.ScreenUpdating = False Set dic = CreateObject("Scripting.Dictionary") Set sh1 = ActiveSheet With sh1 hh = .Cells(1, 1).Height For r = 2 To .Cells(Rows.Count, 1).End(xlUp).Row If IsNumeric(Mid(.Cells(r, 2).Value, 3, 1)) Then dkey = Left(.Cells(r, 2).Value, 2) Else dkey = Left(.Cells(r, 2).Value, 3) End If If dic.exists(dkey) = False Then dic.Add dkey, r Else dic.Item(dkey) = dic.Item(dkey) & "," & r End If Next r End With For Each dkey In dic.keys Set sh2 = Worksheets.Add(After:=Worksheets(Worksheets.Count)) With sh2 r = 0 .Name = dkey For Each wr In Split(dic.Item(dkey), ",") r = r + 1 .Cells(r, 1).Resize(, 4).Value = sh1.Cells(wr, 1).Resize(, 4).Value .Rows(r).RowHeight = hh Next wr End With Next dkey Set dic = Nothing Application.ScreenUpdating = True End Sub ----------