お世話になります。
For　Each構文って便利だなぁと思いました。

[code]Option Explicit
Sub yoshu01()
'[1]
Dim shFm As Worksheet
Dim lnFm As Long
Dim lnFmMx As Long
Set shFm = Worksheets("main")
InFmMx = shFm.Range("C65536").End(xlUp).Row
For lnFm = 2 To InFmMx
If shFm.Range("B" & lnFm).Value <> shFm.Range("B" & lnFm + 1).Value Then 'ここで条件を追加しました
Debug.Print shFm.Range("B" & lnFm).Value
End If
Next

End Sub
Sub yoshu02()
'[2]
Dim shFm As Worksheet
Dim shTo As Worksheet
Dim lnFm As Long
Dim lnFmMx As Long
Dim st As String
Set shFm = Worksheets("main")
lnFmMx = shFm.Range("C65536").End(xlUp).Row
For lnFm = 2 To lnFmMx
If shFm.Range("B" & lnFm).Value <> shFm.Range("B" & lnFm + 1).Value Then
st = shFm.Range("B" & lnFm).Value
Sheets("main1").Copy After:=Sheets(2) 'シート追加、シート名の指定しました
Set shTo = ActiveSheet
shTo.Name = st
End If
Next

End Sub
Sub yoshu03()
'[3]
delete_renshu 'ここにシート削除のプロシージャを追加しました
Dim shFm As Worksheet
Dim shTo As Worksheet
Dim lnFm As Long
Dim lnFmMx As Long
Dim st As String
Set shFm = Worksheets("main")
lnFmMx = shFm.Range("C65536").End(xlUp).Row
For lnFm = 2 To lnFmMx
If shFm.Range("B" & lnFm).Value <> shFm.Range("B" & lnFm + 1).Value Then
st = shFm.Range("B" & lnFm).Value
Sheets("main1").Copy After:=Sheets(2)
Set shTo = ActiveSheet
shTo.Name = st
End If
Next

End Sub
Sub delete_renshu()
Dim sh As Worksheet
Application.DisplayAlerts = False
For Each sh In Worksheets
If Left(sh.Name, 4) <> "main" Then
sh.Delete
End If
Next
Application.DisplayAlerts = True
End Sub[code/]

2020/07/28 08:12