Kod Hk.

[MELTUN]

Daha önce benzer bir konuda sitede yazılmış olan kod bilgisayarımın çökmesi sonucu silinmiştir.Geçmiş mesajlarım içeriğinede ulaşamadığımdan
Aşağıda linki bulunan konu ilginize ve bilginize sunulmuştur. http://s2.dosya.tc/server2/nn3m10/Rica_ve_Istek.xlsx.html
• “ A” Sütununda altta bulunan“Son 800 : “ yazılı hücre içeriğinin tamamı “1.Koşu” kelimesinin bulunduğu satırın “ J “ hücresine yazdırılması,

• Takiben “ A” hücresinden ” J “ hücresi dâhil yatay kopyalanarak ayni satırın “ M” sütun hücresinden itibaren yatay olarak yazdırılması,

• Yine takiben ”M” den İtibaren yatay olarak yazdırılan veriler bu defa aşağıya doğru ve bir alttaki “A” sütununda bulunan “2.Koşu” kelimesinin bir üst satırına kadar ayni şekilde hücre içeriklerinin yazdırılması kısaca içeriğinde koşu ibaresi bulunan satırlarda ayni işlemin uygulanması,

• Tüm bu işlemler yapıldıktan sonra “B” sütununda bulunan veri sonunda ki “()” parentez içerisindeki rakamlar “K” Sütununa“()”parantez’ den sonra ki harfler ise “L” sütununa yazdırılmalı ve işlem bittikten sonra “B” sütundaki verinin sonundaki ”( “ sonraki veriler silinerek işlemin tamamlanması hususunda yardımlarınızı rica ediyorum.İlginiz için teşekkür ederim.Saygılarımla

 

[MELTUN]

Yardımlarınızı bekliyorum Saygılarımla

 

[MELTUN]

İlginizi bekliyorum.Saygılarımla

 

[MELTUN]

Kod Hk

Veri tabanı oluşturmak isteğime Sn;mucit77 arkadaşımızın cevaben yazmış olduğu kod' a araştırmam sonucu bu gün ulaşabildim.İzah etmeye çalıştığım konumlar doğrultusu ve izni dahilinde ekleme ve uyarlama yapılarak yeniden düzenlenmesi hususunu gerek şahsından gerekse yetkili ve konuya çözüm getirebilecek arkadaşlarımdan bekliyorum.Saygılarımla

Sub KOD()
Application.ScreenUpdating = False
For a = 1 To Range("A65536").End(3).Row
If Right(Replace(Cells(a, "A"), "*", ""), 4) = "Koşu" Then
If b > 0 Then
Range(Cells(b, "A"), Cells(b, "J")).Copy
Range(Cells(b, "M"), Cells(a - 1, "M")).Select
ActiveSheet.Paste
End If
b = a
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[ÖmerBey]

İyi çalışmalar...

Sub KOD()
Application.ScreenUpdating = False
For a = 1 To Range("A65536").End(3).Row
If InStr(1, Cells(a, "A"), "Koşu") > 0 Then
    If b > 0 Then
        Range(Cells(b, "A"), Cells(b, "J")).Copy
        Range(Cells(b, "M"), Cells(a - 1, "M")).Select
        ActiveSheet.Paste
    End If
    b = a
ElseIf InStr(1, Cells(a, "A"), "Son*800:") > 0 And b > 0 Then
    Cells(b, "J") = Cells(a, "A")
End If

If InStr(1, Cells(a, "B"), ")") > 0 Then
    Cells(a, "K") = Split(Split(Cells(a, "B"), ")")(0), "(")(1)
    Cells(a, "L") = Split(Cells(a, "B"), ")")(1)
    Cells(a, "B") = Split(Cells(a, "B"), "(")(0)
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[MELTUN]

İyi çalışmalar...

Sub KOD()
Application.ScreenUpdating = False
For a = 1 To Range("A65536").End(3).Row
If InStr(1, Cells(a, "A"), "Koşu") > 0 Then
    If b > 0 Then
        Range(Cells(b, "A"), Cells(b, "J")).Copy
        Range(Cells(b, "M"), Cells(a - 1, "M")).Select
        ActiveSheet.Paste
    End If
    b = a
ElseIf InStr(1, Cells(a, "A"), "Son*800:") > 0 And b > 0 Then
    Cells(b, "J") = Cells(a, "A")
End If

If InStr(1, Cells(a, "B"), ")") > 0 Then
    Cells(a, "K") = Split(Split(Cells(a, "B"), ")")(0), "(")(1)
    Cells(a, "L") = Split(Cells(a, "B"), ")")(1)
    Cells(a, "B") = Split(Cells(a, "B"), "(")(0)
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Sn;Mucit 77
Öncelikle yardımlarınız için teşekkür ederim Yazmış olduğunuz kod mükemmel çalıştı,
ancak açıklama ile işaretlediğim satırlar içeriğinde bahis olunduğu gibi Son 800: değerlerini "j"sütununa almadı dolayısıyla ayni satıra yazılamadı.
• Son 800 hücre içeriği "J" sütununa koşu ifadesi
satırına yazdırılması ve gerek ayni sütunda gerekse "S"Sütunun da koşu nolarını yazdırdığımız gibi alt alta yazdırılması .
Ayrıca;
• Kod son dolu "koşu ibaresinin" bulunduğu satıra kadar gayet güzel çalışıyor. "A1908" son dolu satır olması nedeniyle kod burada çalışmayı 5.Koşu satırını yazdıktan sonra sonlandırıyor.Görüldüğü gibi 6.Koşu satır içeriğinin yazılması gereken 16 satır daha mevcut çözmek içinse fikren burada" A1908" deki 6.koşu kelimesinin "A1927" boş satıra kopyalanırsa neticesi kod " A1927" son dolu satır olarak göreceğinden A1927 kadar tüm veriler yazılmış olacak ve sorun tamamen çözülmüş olacaktır. Saygılarımla




http://s9.dosya.tc/server/vopjac/CALISMA_SONUCLARI.rar.html