Witam. Mam zadanie stworzyć program, który w istniejących skoroszytach wyszukuje ciągi geometryczne oraz przepisuje je do nowego skoroszytu. Następnie pod ciągiem zapisuje sumę elementów, czy ciąg jest zbieżny oraz jego iloraz. Ciągi zbieżne mają być wyróżnione obramowaniem, a liczby nieparzyste mają być pogrubione. Część programu mam zrobione, problem jest w kopiowaniu ciągów. Program wkleja ten sam ciąg w nieskończoność i nie chce przerzucić na kolejny skoroszyt. Kod nie może zawierać funkcji typu: For each, Range, Object.
Option Explicit
Option Base 1
Sub ciagG()
Const d = 22
Dim t(100 * 25) As Double, i As Integer, j As Integer, q As Double
Dim licz_ciagi As Integer, ark As Worksheet, ark_i As Byte, k As Integer
Dim nr_wiersza As Integer
Dim suma As Integer
Dim ile As Byte
Dim n As Byte
Dim ciag As String
ile = Sheets.Count 'zliczanie skoroszytów
ark_i = addWS()
n = 1
Set ark = Worksheets(ark_i)
For n = 1 To ark_i Step 1 'Pętla wykonująca się tyle razy, ile jest skoroszytów
k = przeszukK(t, n)
i = 1
nr_wiersza = 1
licz_ciagi = 0
n = n + 1
Do While i + 2 <= k
q = Round(t(i + 1) / t(i), d)
If Round(t(i + 2) / t(i + 1), d) = q Then 'Ustalanie iloczyna ciągu geometrycznego
Set ark = Worksheets(ark_i)
licz_ciagi = licz_ciagi + 1
'przepisanie wyników do tablicy
ark.Cells(nr_wiersza, licz_ciagi).Value = t(i)
ark.Cells(nr_wiersza + 1, licz_ciagi).Value = t(i + 1)
ark.Cells(nr_wiersza + 2, licz_ciagi).Value = t(i + 2)
nr_wiersza = nr_wiersza + 2
suma = t(i) + t(i + 1) + t(i + 2)
'sprawdzenie jaki ciag geometryczny
If q > 0 And t(i) > t(i + 1) Then
ciag = "zbieżny"
Else
ciag = "Ciąg nie jest zbieżny"
End If
End If
For j = i + 3 To k
If Round(t(j) / t(j - 1), d) <> q Then Exit Do
If Round(t(j) / t(j - 1), d) = q Then
nr_wiersza = nr_wiersza + 1
ark.Cells(nr_wiersza, licz_ciagi).Value = t(j)
suma = suma + t(j)
ark.Cells(nr_wiersza + 1, licz_ciagi).Value = q
ark.Cells(nr_wiersza + 2, licz_ciagi).Value = suma
ark.Cells(nr_wiersza + 3, licz_ciagi).Value = ciag
Else
i = j - 2
nr_wiersza = 1
Exit For
End If
Next j
Loop
Next n
End Sub
Function addWS() As Byte
Dim i As Integer
i = Worksheets.Count
Worksheets.Add After:=Worksheets(i)
addWS = i + 1
End Function
Function przeszukK(t() As Double, n As Byte) As Integer
Dim zawartosc As Variant
Dim i As Byte, j As Byte, obj As Worksheet, k As Integer
Set obj = Worksheets(n)
k = 0
For j = 1 To 25
For i = 1 To 100
zawartosc = obj.Cells(i, j).Value
If Not IsEmpty(zawartosc) Then
If IsNumeric(zawartosc) Then
k = k + 1
t(k) = zawartosc
If (zawartosc Mod 2) <> 0 Then
obj.Cells(i, j).Font.Bold = True
End If
End If
End If
Next i
Next j
przeszukK = k
End Function
Visual Basic for Applications