Aralıklı dolu satırları birleştirip aktarma

[kelkitli]

Değerli Dostlar Selamlar,
Ekteki dosyada H6:M18 alanındaki veriler Data isimli sayfaya aktarılacak.
6. Satırdan 18. Satıra kadar, 12. Satır es geçilecek.
Her satırın H,J,L sütunlarındaki veriler alınıp Data isimli sayfada 3 erli guruplara peşpeşe aktarılacaklar.
Data satır seçme Günlük liste L1 hücresindeki tarih Data A:A da aranarak belirlenecek.
H6,J6,L6 veriler Data D,E,F
H7,J7,L7 veriler Data G,H,I
H8,J8,L8 veriler Data J,K,L
H9,J9,L9 veriler Data M,N,O
H10,J10,L10 veriler Data P,Q,R
H11,J11,L11 veriler Data S,T,U
Birinci gurup tamam
V sütunu Skip
İkinci gurup aynı şekil
İlgilenen arkadaşlara Teşekkürler.

 

[kelkitli]

Değerli dostlar Selamlar,
Döngü kurmayı yapamıyorum.
Yaklaşık şuna benzer bir mantıkla bu konu çözüme kavuşabilirmi?
Sub Kaydet()
Set s1 = Sayfa1
Set S2 = Sayfa4
Set KRİTER = s1.Range("L1")
ara = S2.[A3:A65536].Find(What:=KRİTER,
For i = 6 To 18
If x = 12 Then GoTo Skip
S2.Cells(j, "d", "e", "f") = s1.Cells(i, " A", "J", "L ")
j = j + 3
If x = 12 Then GoTo Skip
Next i
End Sub

 

[Skorpiyon]

Sayın kelkitli,

Sanırım bu işinizi görür.

Sub Düğme744_Tıklat()
Dim son, a
Sheets("Data").Select
Range("A1").Select
son = WorksheetFunction.CountA(Sheets("DATA").Range("A3:A65536"))
For a = 1 To son
If Sheets("GÜNLÜKLİSTE").Cells(1, 12).Value = Sheets("DATA").Cells(a, 1).Value Then
Cells(a, 4).Select
'Burayı (bu saatte) döngüye alamadım
ActiveCell.Value = Sheets("GÜNLÜKLİSTE").Cells(6, 8).Value
ActiveCell.Offset(0, 1).Value = Sheets("GÜNLÜKLİSTE").Cells(6, 10).Value
ActiveCell.Offset(0, 2).Value = Sheets("GÜNLÜKLİSTE").Cells(6, 12).Value
ActiveCell.Offset(0, 3).Value = Sheets("GÜNLÜKLİSTE").Cells(7, 8).Value
ActiveCell.Offset(0, 4).Value = Sheets("GÜNLÜKLİSTE").Cells(7, 10).Value
ActiveCell.Offset(0, 5).Value = Sheets("GÜNLÜKLİSTE").Cells(7, 12).Value
'Devamını size bırakıyorum. Dedim ya bu saatte bu kadar oluyor
End If
Next a
End Sub

Saygılarımla...

 

[Skorpiyon]

Sayın kelkitli,

Bu arada,

dosyanıza 1 düğme ekleyerek kodları yazaım dedim, tam 744'üncü düğmeyi ekledi. Doğrusu iyi uğraşmışsınız Tebrikler...

Saygılarımla...

 

[kelkitli]

Teşekkür ederim Sayın Skorpiyon,
Gececenin bu saatinde uyanık olmanız dahi bir hayat göstergesidir.
Cevap vermiş olmanız yeterince değere haizdir.
Düğme değince 744 olduğunu bilmiyordum. Kardeş yaş 47, 40 ımda başladım bilişim işine. Vatana asker yetiştiriyoruz ne yapalım. Keşke cevabınızı bir sonraki günün gündüzünde verseydiniz. Yinede olabilir diye düşünüp bekliyorum. Sizler gibi güzel insanlar oldukça bekleriz de. Bu program oldukça büyük ek sayfaları kırptıktan sonra özetini göndermiştim. O yüzden çok düğmeli görünüyor.

 

[Skorpiyon]

Sayın kelkitli,

Peki yazdığımız kodlar işinizi gördü mü, bunu belirtmemişsiniz. Eğer yok benim istediğim böyle bir şey değil diyorsanız, elimizden bir şey gelir mi bakalım. Eğer yardımcı olabilirsek veya en azından fikir verebilirsek bu bile büyük mutluluk olur bizim için.

Saygılarımla...

 

[kelkitli]

Sayın skorpiyon bu gün kodlar üzerinde çalışma yapamadım. Şöyle bir durum var zaten hücre bazında aktarmayı yaptım kullanıyorum uzun zamandır. Sıkıntım kodların uzun olmasından ve yavaş işlemesinden. Onun için döngü kurmaya çalıştım. Sizin yazdığınız kodları modüle koyaladım çalıştırdım ama istediğim işlemi tamamlayabilmesi için üzerinde çalışamadım. Tamamlama imkânınız varsa çok memnun olurum. Bilgi eksiliğinden dolayı çalışma yaparken çok deneme yanılma yöntemini kullanıyorum.

 

[kelkitli]

Bir önceki mesaja benim kullandığım kodları çalışır şekil ekledim. Çalışma şeklinin görülebilmesi açısından.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Sub AKTAR()
    Set SGL = Sheets("GÜNLÜKLİSTE")
    Set SD = Sheets("Data")
    KRİTER = SGL.[L1]
    SD.Select
    For X = 4 To [A65536].End(3).Row
    If Cells(X, 1) = KRİTER Then
    Cells(X, 1).Select
    Cells(X, "D") = SGL.Cells(6, "H")
    Cells(X, "E") = SGL.Cells(6, "J")
    Cells(X, "F") = SGL.Cells(6, "L")
    Cells(X, "G") = SGL.Cells(7, "H")
    Cells(X, "H") = SGL.Cells(7, "J")
    Cells(X, "I") = SGL.Cells(7, "L")
    Cells(X, "J") = SGL.Cells(8, "H")
    Cells(X, "K") = SGL.Cells(8, "J")
    Cells(X, "L") = SGL.Cells(8, "L")
    Cells(X, "M") = SGL.Cells(9, "H")
    Cells(X, "N") = SGL.Cells(9, "J")
    Cells(X, "O") = SGL.Cells(9, "L")
    Cells(X, "P") = SGL.Cells(10, "H")
    Cells(X, "Q") = SGL.Cells(10, "J")
    Cells(X, "R") = SGL.Cells(10, "L")
    Cells(X, "S") = SGL.Cells(11, "H")
    Cells(X, "T") = SGL.Cells(11, "J")
    Cells(X, "U") = SGL.Cells(11, "L")
    Cells(X, "W") = SGL.Cells(13, "H")
    Cells(X, "X") = SGL.Cells(13, "J")
    Cells(X, "Y") = SGL.Cells(13, "L")
    Cells(X, "Z") = SGL.Cells(14, "H")
    Cells(X, "AA") = SGL.Cells(14, "J")
    Cells(X, "AB") = SGL.Cells(14, "L")
    Cells(X, "AC") = SGL.Cells(15, "H")
    Cells(X, "AD") = SGL.Cells(15, "J")
    Cells(X, "AE") = SGL.Cells(15, "L")
    Cells(X, "AF") = SGL.Cells(16, "H")
    Cells(X, "AG") = SGL.Cells(16, "J")
    Cells(X, "AH") = SGL.Cells(16, "L")
    Cells(X, "AI") = SGL.Cells(17, "H")
    Cells(X, "AJ") = SGL.Cells(17, "J")
    Cells(X, "AK") = SGL.Cells(17, "L")
    Cells(X, "AL") = SGL.Cells(18, "H")
    Cells(X, "AM") = SGL.Cells(18, "J")
    Cells(X, "AN") = SGL.Cells(18, "L")
    Cells(X, "AP") = SGL.Cells(20, "H")
    Cells(X, "AQ") = SGL.Cells(20, "L")
    Cells(X, "AT") = SGL.Cells(21, "H")
    Cells(X, "AU") = SGL.Cells(21, "L")
    End If
    Next
    MsgBox "AKTARIM İŞLEMİ TAMAMLANMIŞTIR.", vbInformation
End Sub

 

[kelkitli]

Selamlar,
Sayın COST_CONTROL Sayın skorpiyon,
sizlere yanıtlarınız için çok teşekkür ederim. Sayın skorpiyon kodlarınız güzel olmuş üzerinde daha da eklemeler yapacağım.
Sayın COST_CONTROL kodlarınızı bu şekliyle
sonuna SGL.Select
Set SGL = Nothing
Set SD = Nothing
şeklinde ekleme yaparak listeme aktardım. Sanıyorum eşitliği ters çevirerek geri çağırma işleminde de rahatça kullanabilirim.
Teşekkürler sizlere
Teşekkürler sizlere.

 

[Skorpiyon]

Sayın kelkitli,

Yardımcı olabildiysek ne mutlu.

Aslında "Devamını size bırakıyorum" derken, aşağıdaki satırların sadece tekrarı söz konusu idi.
..........................................
ActiveCell.Offset(0, 1).Value = Sheets("GÜNLÜKLİSTE").Cells(6, 10).Value
ActiveCell.Offset(0, 2).Value = Sheets("GÜNLÜKLİSTE").Cells(6, 12).Value
ActiveCell.Offset(0, 3).Value = Sheets("GÜNLÜKLİSTE").Cells(7, 8).Value
ActiveCell.Offset(0, 4).Value = Sheets("GÜNLÜKLİSTE").Cells(7, 10).Value
ActiveCell.Offset(0, 5).Value = Sheets("GÜNLÜKLİSTE").Cells(7, 12).Value
..........................................

Kolay gelsin, Saygılarımla...

 

[kelkitli]

Sağol Sayın skorpiyon bu dediğiniz kısmı zaten çoğalttım.
Tabiiki en güzel şekilde yardımcı oldunuz ne demek kardeş.

Sub kaydet()
Dim son, a
Sheets("Data").Select
Range("A1").Select
son = WorksheetFunction.CountA(Sheets("DATA").Range("A3: A65536"))
For a = 1 To son
If Sheets("GÜNLÜKLİSTE").Cells(1, 12).Value = Sheets("DATA").Cells(a, 1).Value Then
Cells(a, 4).Select
'Burayı (bu saatte) döngüye alamadım
ActiveCell.Value = Sheets("GÜNLÜKLİSTE").Cells(6, 8).Value
ActiveCell.Offset(0, 1).Value = Sheets("GÜNLÜKLİSTE").Cells(6, 10).Value
ActiveCell.Offset(0, 2).Value = Sheets("GÜNLÜKLİSTE").Cells(6, 12).Value
ActiveCell.Offset(0, 3).Value = Sheets("GÜNLÜKLİSTE").Cells(7, 8).Value
ActiveCell.Offset(0, 4).Value = Sheets("GÜNLÜKLİSTE").Cells(7, 10).Value
ActiveCell.Offset(0, 5).Value = Sheets("GÜNLÜKLİSTE").Cells(7, 12).Value
ActiveCell.Offset(0, 6).Value = Sheets("GÜNLÜKLİSTE").Cells(8, 8).Value
ActiveCell.Offset(0, 7).Value = Sheets("GÜNLÜKLİSTE").Cells(8, 10).Value
ActiveCell.Offset(0, 8).Value = Sheets("GÜNLÜKLİSTE").Cells(8, 12).Value
ActiveCell.Offset(0, 9).Value = Sheets("GÜNLÜKLİSTE").Cells(9, 8).Value
ActiveCell.Offset(0, 10).Value = Sheets("GÜNLÜKLİSTE").Cells(9, 10).Value
ActiveCell.Offset(0, 11).Value = Sheets("GÜNLÜKLİSTE").Cells(9, 12).Value
ActiveCell.Offset(0, 12).Value = Sheets("GÜNLÜKLİSTE").Cells(10, 8).Value
ActiveCell.Offset(0, 13).Value = Sheets("GÜNLÜKLİSTE").Cells(10, 10).Value
ActiveCell.Offset(0, 14).Value = Sheets("GÜNLÜKLİSTE").Cells(10, 12).Value
ActiveCell.Offset(0, 15).Value = Sheets("GÜNLÜKLİSTE").Cells(11, 8).Value
ActiveCell.Offset(0, 16).Value = Sheets("GÜNLÜKLİSTE").Cells(11, 10).Value
ActiveCell.Offset(0, 17).Value = Sheets("GÜNLÜKLİSTE").Cells(11, 12).Value
ActiveCell.Offset(0, 19).Value = Sheets("GÜNLÜKLİSTE").Cells(13, 8).Value
ActiveCell.Offset(0, 20).Value = Sheets("GÜNLÜKLİSTE").Cells(13, 10).Value
ActiveCell.Offset(0, 21).Value = Sheets("GÜNLÜKLİSTE").Cells(13, 12).Value
ActiveCell.Offset(0, 22).Value = Sheets("GÜNLÜKLİSTE").Cells(14, 8).Value
ActiveCell.Offset(0, 23).Value = Sheets("GÜNLÜKLİSTE").Cells(14, 10).Value
ActiveCell.Offset(0, 24).Value = Sheets("GÜNLÜKLİSTE").Cells(14, 12).Value
ActiveCell.Offset(0, 25).Value = Sheets("GÜNLÜKLİSTE").Cells(15, 8).Value
ActiveCell.Offset(0, 26).Value = Sheets("GÜNLÜKLİSTE").Cells(15, 10).Value
ActiveCell.Offset(0, 27).Value = Sheets("GÜNLÜKLİSTE").Cells(15, 12).Value
ActiveCell.Offset(0, 28).Value = Sheets("GÜNLÜKLİSTE").Cells(16, 8).Value
ActiveCell.Offset(0, 29).Value = Sheets("GÜNLÜKLİSTE").Cells(16, 10).Value
ActiveCell.Offset(0, 30).Value = Sheets("GÜNLÜKLİSTE").Cells(16, 12).Value
ActiveCell.Offset(0, 31).Value = Sheets("GÜNLÜKLİSTE").Cells(17, 8).Value
ActiveCell.Offset(0, 32).Value = Sheets("GÜNLÜKLİSTE").Cells(17, 10).Value
ActiveCell.Offset(0, 33).Value = Sheets("GÜNLÜKLİSTE").Cells(17, 12).Value
ActiveCell.Offset(0, 34).Value = Sheets("GÜNLÜKLİSTE").Cells(18, 8).Value
ActiveCell.Offset(0, 35).Value = Sheets("GÜNLÜKLİSTE").Cells(18, 10).Value
ActiveCell.Offset(0, 36).Value = Sheets("GÜNLÜKLİSTE").Cells(18, 12).Value
'Devamını size bırakıyorum. Dedim ya bu saatte bu kadar oluyor
End If
Next a
End Sub