Kolon bakıp satır bazında verı uretmek

[haso_excel]

Merhaba arkadaşlar,

Ekdeki dosyada da anlatmaya çalıştım. Bir database dosyam var, Kodlar E kolonundan başlıyor bazen eksilebilir bazen de kod eklenebilir.
Ben her bir kodu satır bazında yazdırıp, yanlarınada ne kadar kod varsa o kadar isim getirmek.
Ama isimde kodlarda satır ve kolon bazında eksilip artabilirler.

 

[haso_excel]

Dosya ekde pardon

 

[Orion1]

Dosyanız ektedir.

Sub aktar()
Dim i As Long, sat As Long, k As Integer, sut As Integer
Sheets("Sheet3").Select
Application.ScreenUpdating = False
sat = 3
With Sheets("Sayfa1")
    .Range("A3:D65536").ClearContents
    For i = 2 To Cells(65536, "A").End(xlUp).Row
        sut = Cells(i, 256).End(xlToLeft).Column
        For k = 5 To sut
            .Cells(sat, "A").Value = Cells(i, "A").Value
            .Cells(sat, "B").Value = Cells(i, "B").Value
            .Cells(sat, "C").Value = Cells(i, "C").Value
            .Cells(sat, "D").Value = Cells(i, "D").Value
            .Cells(sat, "E").Value = Cells(i, k).Value
            sat = sat + 1
        Next k
    Next i
    .Select
End With
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlnadı." & vbLf & _
vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"

End Sub

 

[haso_excel]

Tesekkurler

 

[Orion1]

Tesekkurler

Rica ederim.

 

[haso_excel]

Sayın Evren bey,

Elinize sağlık rapor istediğim gibi fakat, kod E2 den başlayıp, kolon sonuna kadar kontrol ediyor. Aslında benim istediğim öernek dosyadada göreceğiniz üzere kontrol E1 den başlaması.
Rica etsem tekrar kod üzerinde gösterir misiniz ? Kontrol nerde başlıyor ben değişikliği yapıyım,

 

[Orion1]

Sayın Evren bey,

Elinize sağlık rapor istediğim gibi fakat, kod E2 den başlayıp, kolon sonuna kadar kontrol ediyor. Aslında benim istediğim öernek dosyadada göreceğiniz üzere kontrol E1 den başlaması.
Rica etsem tekrar kod üzerinde gösterir misiniz ? Kontrol nerde başlıyor ben değişikliği yapıyım,

İlgili satırı aşağıdaki ile değiştiriniz.

For i = 1 To Cells(65536, "A").End(xlUp).Row

 

[haso_excel]

E1 den itibaren istediğim verileri kolon bazında alıyor fakat A1 ile D1 de ne varsa onu aldığı verilerin yanına koyuyor. Aslında A2 ile D2 den başlaması lazım

 

[Orion1]

Sayın Evren bey,
Elinize sağlık rapor istediğim gibi fakat, kod E2 den başlayıp, kolon sonuna kadar kontrol ediyor. Aslında benim istediğim öernek dosyadada göreceğiniz üzere kontrol E1 den başlaması.
Rica etsem tekrar kod üzerinde gösterir misiniz ? Kontrol nerde başlıyor ben değişikliği yapıyım,

E1 den itibaren istediğim verileri kolon bazında alıyor fakat A1 ile D1 de ne varsa onu aldığı verilerin yanına koyuyor. Aslında A2 ile D2 den başlaması lazım

Kodlar ilk yazdığımda 2nci satırdan başlayıyordu .Yukarıdaki ilk mesajdadad zatensizde bunu belirtmişsiniz.1nci satırdan başlamsaını istemiştiniz.Bende döngüyü 1nci satırdan başlar şekilde size verdim.
oysa şimdi alttaki 2nci mesajda 2nci satırdan başlaması gerekiyor demişsiniz.
Bende anlamadım siz ne yapmak istiyorsunuz.1nci satırdan başlamasını istiyorsanız ilk mesajımı 2nci satırdan başlamasını istiyorsanzı size verdiğim 2nci satırdan başlayan düzeltmeyi kullanın.

 

[haso_excel]

Örneğimde de istediğim formatı gösterdim. E1 den başlamak üzere kodların yanına A2 ile D2 de ki kodları kontrol edip yanına yazacak

 

[Orion1]

Örneğimde de istediğim formatı gösterdim. E1 den başlamak üzere kodların yanına A2 ile D2 de ki kodları kontrol edip yanına yazacak

Ne dediğinizi anlamadım.Bitmiş vaziyetini başka bir sheet açıp orada gösterin o zaman.

 

[haso_excel]

Dosya ekde ilginiz için tekrar teşekkür ederim.

 

[halit3]

alternatif kod

Sub aktar()
sat = Worksheets("Sheet1").[a65536].End(3).Row + 1
For i = 2 To Worksheets("DATABASE").[a65536].End(3).Row
deg1 = Worksheets("DATABASE").Cells(i, "A").Value
deg2 = Worksheets("DATABASE").Cells(i, "B").Value
deg3 = Worksheets("DATABASE").Cells(i, "C").Value
deg4 = Worksheets("DATABASE").Cells(i, "D").Value
For r = 5 To WorksheetFunction.CountA(Worksheets("DATABASE").Range("E1:IV1")) + 4
Worksheets("Sheet1").Cells(sat, "A").Value = deg1
Worksheets("Sheet1").Cells(sat, "B").Value = deg2
Worksheets("Sheet1").Cells(sat, "C").Value = deg3
Worksheets("Sheet1").Cells(sat, "D").Value = deg4
Worksheets("Sheet1").Cells(sat, "E").Value = Worksheets("DATABASE").Cells(1, r).Value
Worksheets("Sheet1").Cells(sat, "F").Value = Worksheets("DATABASE").Cells(i, r).Value
sat = sat + 1
Next r
Next i
MsgBox "işlem tamam"
End Sub

 

[haso_excel]

Teşekkür ederim, elinize sağlık tamn istediğim buydu