Excelde İki Satır Arasına Vba İle Kayıt Ekleme

Kod:
Sub Aktar(ByVal syf As Worksheet)

    Dim bul, ara As Range, i As Integer, dic As Object, aranan As String



    Set dic = CreateObject("Scripting.dictionary")

    With ThisWorkbook.Worksheets("Kimya")

        For i = 4 To 18

            bul = Application.Match(syf.Cells(i, "B").Value2, .Range("C:C"), 0)

            If Not IsError(bul) Then

                'içerik eklenirse burdan tekrar düzenle

                For Each ara In .Range("I" & bul & ":BU" & bul)

                    If Len(Trim(ara.Value)) > 0 Then

                        aranan = .Cells(2, ara.Column).Value

                        If Not dic.exists(aranan) Then dic(aranan) = 0

                    End If

                Next

            End If

        Next

    End With

    If dic.Count > 0 Then syf.Range("G3").Resize(, dic.Count).Value = dic.keys

    Set dic = Nothing

End Sub



Sub Aktar2(ByVal syf As Worksheet)

        Dim bulW_W, bulPH, sayBul As Integer, sonToplam As Integer, sonSutunG As Integer

        

        sayBul = 0

        With syf

            sonToplam = .Cells(Rows.Count, "E").End(3).Row 'E sütuna göre son satir no

            bulW_W = Application.Match("w / w", .Range("D:D"), 0)

            bulPH = Application.Match("pH", .Range("B:B"), 0)

            If IsError(bulW_W) Then Exit Sub

            If IsError(bulPH) Then Exit Sub

            If WorksheetFunction.CountA(.Range("G" & sonToplam & ":XFD" & sonToplam)) = 0 Then Exit Sub

            

            Application.EnableEvents = False

            Application.ScreenUpdating = False

            

            If bulPH - bulW_W > 1 Then .Range(.Cells(bulW_W + 1, 1), .Cells(bulPH - 1, 1)).EntireRow.Delete

            sonSutunG = .Cells(sonToplam, Columns.Count).End(xlToLeft).Column

            If sonSutunG < 7 Then GoTo sonSub

            ReDim arrBekle(1 To 3, 1 To 1)

            For i = 7 To sonSutunG 'F sütun

                If .Cells(sonToplam, i).Value2 > 0 Then

                    sayBul = sayBul + 1

                    ReDim Preserve arrBekle(1 To 3, 1 To sayBul) '3 olma sebebi C sütunu oldugu icin

                    arrBekle(1, sayBul) = .Cells(3, i).Value

                    'arrBekle(2, sayBul) = "%"

                    arrBekle(2, sayBul) = ""

                    arrBekle(3, sayBul) = .Cells(sonToplam, i).Value

                End If

            Next

sonSub:

            If sayBul > 0 Then

                .Range("A" & bulW_W + 1).Resize(sayBul).EntireRow.Insert

                .Range("B" & bulW_W + 1).Resize(sayBul, 3).Value = Application.Transpose(arrBekle)

            End If

            Application.EnableEvents = True

            Application.ScreenUpdating = True

    End With

End Sub