visual basic excel Liczby pierwsze

Question

Witam. Czy ktoś by pomogł? W istniejacych arkuszach danego skoroszytu wyszukać komorki zawierajace liczny pierwsze (przeszzukiwanie wierszami). Znalezione liczby przedstawic rosnaco w pierwszej kolumnie nowo utworzonego arkusza.

Answer 1

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

 

Comments

Wstaw jako kod

---

Dzięki za komentarz. Jak wstawiałem kod to właśnie coś było nie tak.