Otomatik kopyalama

[kayahan84]

Merhaba, ekte gönderdiğim dosyada istediğim şey, ilk 3 örnekte olduğu gibi alt alta yazılı parçaların yanyana yazılmasını istyorum. Parça adeti 3000 küsür olduğu için tek tek yapmak yerine otomatik olarak yapacak formül ya da makro varmıdır?
Teşekkürler

 

[Murat OSMA]

Merhaba,

Bu kodları kullanabilirsiniz..

[SIZE="2"]Sub Emre()
    Dim i&, sat&, sut&
    sut = 3
    For i = 2 To Range("A65536").End(3).Row
        If Cells(i, 1).Value <> "" Then
            sut = 3: sat = i
            Cells(sat, sut).Value = Cells(i, 2).Value
                Else
            sut = sut + 1
            Cells(sat, sut).Value = Cells(i, 2).Value
        End If
    Next i
    MsgBox "İşlem Tamamlandı.", vbInformation, "ExcelArsivi.Com"
    sut = Empty: sat = Empty: i = Empty
End Sub[/SIZE]

 

[Asri]

Alternatif;

Sub yanayaz()
   Application.ScreenUpdating = False
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   kolon = 3
   For i = sonsatir To 2 Step -1
     kod = Cells(i, "A").Value
     adres = Cells(i, "B").Value
     If kod = "" And adres <> "" Then
        Range(Cells(i, 2), Cells(i, kolon)).Cut Destination:=Cells(i - 1, 3)
        kolon = kolon + 1
     Else
        kolon = 3
     End If
     adres = Cells(i, "B").Value
     If kod = "" And adres = "" Then
        Rows(i).Delete
     End If
   Next i
   Application.ScreenUpdating = True
End Sub

 

[YUSUF44]

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz. verilerinizin çokluğuna göre işlemin tamamlanması uzun sürebilir:

Sub aktar()
son = Cells(Rows.Count, "B").End(3).Row
For a = Cells(Rows.Count, "A").End(3).Row To 2 Step -1
    If Cells(a, "A") <> "" Then
        For b = a To son
            yeni = Cells(a, Columns.Count).End(xlToLeft).Column + 1
            Cells(a, yeni) = Cells(b, "B")
        Next
    son = a - 1
    End If
Next

End Sub

 

[kayahan84]

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz. verilerinizin çokluğuna göre işlemin tamamlanması uzun sürebilir:

Sub aktar()
son = Cells(Rows.Count, "B").End(3).Row
For a = Cells(Rows.Count, "A").End(3).Row To 2 Step -1
    If Cells(a, "A") <> "" Then
        For b = a To son
            yeni = Cells(a, Columns.Count).End(xlToLeft).Column + 1
            Cells(a, yeni) = Cells(b, "B")
        Next
    son = a - 1
    End If
Next

End Sub

altın üyeyim zaten hocam örnek dosyaya işler misiniz rica etsem olmadı yapamadım

 

[kayahan84]

Merhaba,

Bu kodları kullanabilirsiniz..

[SIZE="2"]Sub Emre()
    Dim i&, sat&, sut&
    sut = 3
    For i = 2 To Range("A65536").End(3).Row
        If Cells(i, 1).Value <> "" Then
            sut = 3: sat = i
            Cells(sat, sut).Value = Cells(i, 2).Value
                Else
            sut = sut + 1
            Cells(sat, sut).Value = Cells(i, 2).Value
        End If
    Next i
    MsgBox "İşlem Tamamlandı.", vbInformation, "ExcelArsivi.Com"
    sut = Empty: sat = Empty: i = Empty
End Sub[/SIZE]

hocam teşekkür ederim. Bu benim örnekte attığım dosya ile uyumlu mu?

 

[kayahan84]

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz. verilerinizin çokluğuna göre işlemin tamamlanması uzun sürebilir:

Sub aktar()
son = Cells(Rows.Count, "B").End(3).Row
For a = Cells(Rows.Count, "A").End(3).Row To 2 Step -1
    If Cells(a, "A") <> "" Then
        For b = a To son
            yeni = Cells(a, Columns.Count).End(xlToLeft).Column + 1
            Cells(a, yeni) = Cells(b, "B")
        Next
    son = a - 1
    End If
Next

End Sub

hocam ekteki excel dosyası görün miyor mu?

 

[kayahan84]

hocam ekteki excel dosyası görün miyor mu?

eki tekrar gönderiyorum hocam

 

[Murat OSMA]

hocam teşekkür ederim. Bu benim örnekte attığım dosya ile uyumlu mu?

Uyumlu mu derken neyi kastediyorsunuz?
​

 

[kayahan84]

Uyumlu mu derken neyi kastediyorsunuz?
​

modülü kopyalağdım zaman edit yapmam gerekiyor mu? ekte excel dosyası attım hocam

 

[Murat OSMA]

Yürümek için adım atmaktan korkmayın..
Lütfen yazdığım kodları deneyip sonucuna bir bakar mısınız?​

 

[kayahan84]

Yürümek için adım atmaktan korkmayın..
Lütfen yazdığım kodları deneyip sonucuna bir bakar mısınız?​

teşekkür ederim. deneyeceğim