Hücre yönlendirme nasıl oluyor

[barissss]

Merhabalar
Ek'te gönderdiğim gibi 2 sütunu 5sütuna otomatik aktaracak formülasyon lazım. Binlerce veri var elimde. Yardım aciiill..

 

[Orion1]

Dosyanız ektedir.

Sub aktar()
Dim k As Range, sat1 As Long, sat2 As Long, i As Long, sh As Worksheet
Dim sut As Integer
Set sh = Sheets("Sheet2")
Sheets("Sheet1").Select
Application.ScreenUpdating = False
sh.Range("A2:IV65536").ClearContents
sat1 = Cells(65536, "G").End(xlUp).Row
sat2 = 2
For i = 2 To sat1
    If WorksheetFunction.CountIf(Range("G2:G" & i), Cells(i, "G").Value) = 1 Then
        sut = 2
        sh.Cells(sat2, "A").Value = Cells(i, "G").Value
        Set k = Range("G" & i & ":G" & sat1).Find(Cells(i, "G").Value, , xlValues, xlWhole)
        If Not k Is Nothing Then
            adr = k.Address
            Do
                sh.Cells(sat2, sut).Value = k.Offset(0, 1).Value
                sut = sut + 1
                Set k = Range("G" & i & ":G" & sat1).FindNext(k)
            Loop While Not k Is Nothing And k.Address <> adr
        End If
        sat2 = sat2 + 1
    End If
Next i
Sheets("Sheet2").Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"

End Sub

 

[barissss]

tıklayınca hata verdi

 

[Orion1]

tıklayınca hata verdi

Hata vermiyor.
Benim yolladığım dosyayı çalıştırdınızmı?
İsterseniz sheet 2 ye bakoın ben çıkarttım çalıştırdım

 

[Necdet]

Merhaba,

Bende uğraşmıştım, boşa gitmesin.

Option Explicit
Sub Duzenle5Li()
Dim i       As Long
Dim j       As Long
Dim Kol     As Integer
Dim Deger   As String
j = 4
Application.ScreenUpdating = False
Range("J5:O" & [j65536].End(3).Row + 1).Clear
For i = 2 To [G65536].End(3).Row
    If Cells(i, "G") <> Deger Then
        Deger = Cells(i, "G")
        Kol = 11
        j = j + 1
        Cells(i, "G").Copy Cells(j, "J")
    End If
    
    Cells(i, "H").Copy Cells(j, Kol)
    Kol = Kol + 1
    If Kol > 15 Then
        Kol = 11
    End If
    
Next i
Application.ScreenUpdating = True
MsgBox "Aktarım Tamamlanmıştır..."
End Sub

 

[muygun]

Syn Evren beyin kodları sorunsuz çalışıyor.
Buda alternatif olsun.

 

[barissss]

hepinize teşekkür ederim. Çok büyük bir zahmetten kurtardınız. Hepinize kolay gelsin..