Kod nie przeszukuje wszystkich istniejących arkuszy, tylko wybrany przez nas zakres
Sub petla()
Dim rsort As Range
Dim liczba As Integer
Dim i As Integer
Dim sheet As Worksheet
liczba = 0
'Podaj zakres, który się interesuje
On Error Resume Next
Set rsort = Application.InputBox _
("Zaznacz zakres", "Zakres", _
ActiveCell.Address, , , , , 8)
'dodany warunek żeby Inputbox się nie sypał, gdy się kliknie Anuluj
If Err.Number <> 0 Then _
Exit Sub
On Error GoTo 0
'dodaj nowy arkusz i nazwij go
Set sheet = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Liczby pierwsze"
'pętla do przetworzenia wszystkich liczb z danego zakresu
For Each cell In rsort
'dodakowy warunek, bo 2 to też liczba pierwsza
If cell.Value = 2 Then
Range("A1").Offset(liczba) = cell.Value
liczba = liczba + 1
End If
'pętla do znalezienia liczb pierwszych
For i = 2 To cell.Value - 1 Step 1
If (cell.Value Mod i) = 0 Then
Exit For
ElseIf i = cell.Value - 1 Then
Range("A1").Offset(liczba) = cell.Value
liczba = liczba + 1
Exit For
End If
Next
Next cell
'sortowanie liczb pierwszych
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("Liczby pierwsze").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Liczby pierwsze").Sort.SortFields.Add2 Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Liczby pierwsze").Sort
.SetRange Range("A1:A24")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub