Zadanie z VBA ciągi geometryczne

0

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

0

VBA to shit. Uż`ywaj SEJeb (DDSI Spie****)

0

Najgorsze jest to, że musi to być w VBA.

1 użytkowników online, w tym zalogowanych: 0, gości: 1