Döngüler ile ilgili kod isteği

[cavanoos]

Merhaba arkadaşlar;

Sayfa1 sekmesinde 1000 ila 3000 satır arasında değişen bir listem mevcut.Şunu yapabilir miyiz ?

Eğer sayfa1 sekmesindeki A1 hücresi dolu ise 300 satır kes ve sayfa2 sekmesine yapıştır.Yapıştırılan satırı sarıya boya.Boyanan 300 satırı sil.Sayfa1 sekmesine geç boş olan 300 satırı sil ve tekrar de ki A1 hücresi dolu mu eğer dolu ise aynı işlemleri yap.Boş ise mesaj kutusuna kayıt edildi yaz.

Arkadaşlar benim amacım kopyalanan 300 satırı veri tabanına kayıt atmak.Sarıya boyamak örnek bir iş sadece.Ben sarıya boya demicem oraya,çalıştırmak istediğim makroyu yazacam.

Yardım edebilir misiniz ?

 

[Korhan Ayhan]

Selamlar,

300 satırlık gruplar halinde aktarım yapacaksanız STEP komutu sizin işinizi görecektir. Aşağıdaki kod yapısını kullanabilirsiniz.

Option Explicit
 
Sub ÜÇYÜZLÜ_GRUPLARLA_AKTAR()
    Dim X As Long
    
    For X = 1 To Sheets("Sayfa1").Range("A65536").End(3).Row Step 300
        Sheets("Sayfa1").Range("A" & X & ":Z" & X + 299).Copy Sheets("Sayfa2").Cells(65536, 1).End(3).Offset(1)
    Next
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[cavanoos]

Korhan Bey;

İlgilendiğiniz için teşekkür ederim.Kodunuz çalıştı.Koda biraz ekleme yapabilir miyiz ?

1-Her 300 satır kopyaladıktan sonra sarıya boyasın.Sonra silsin.
2-En son kopyalanan kısım,kaç adetse o kadar satır kalsın sayfa2 de.

Çok detaylı bir tablo hazırladım.Sonuna geldim burada tıkandım.Yukarıdaki işlem basit bir örnek ama kod yapısını öğrenirsem tablomu bitireceğim.

 

[Korhan Ayhan]

Selamlar,

Yapıştırma işleminden sonra hangi sayfadaki 300 satır sarıya boyanacak?
Yapıştırma işleminden sonra hangi sayfadaki 300 satır silinecek?

Küçük bir örnek dosya ekleyerek yapmak istediğinizi açıklarsanız daha hızlı sonuca gidebiliriz.

 

[cavanoos]

Korhan Bey;

Sayfa2 sekmesinde 300 satır boyanacak ve silinecek.Sonra sayfa1 sekmesine geçilecek.Az önce kopyalanan 300 satır silinecek.Tekrar döngü başlayacak.


2000 satırlık insert sorgusunu tek seferde içeri atamadığım için bunlarla uğraşıyorum.İlk 300 satır için aşağıdaki makro kodunu kullanıp içeri atıyorum.Aşağıdaki kodu bir şekilde döngü içerisine sokabilirsem,önce 300 satır,sonra diğer 300 diye devam edip,kayıt atabilirsem,yukarıdaki işlemle hiç uğraşmam.

Ne yapmak istediğimi umarım anlatabilmişimdir.

Sub PosTutarları2_K2()
Dim cn As ADODB.Connection
Dim cm As ADODB.Command
Set cn = New ADODB.Connection
Set cm = New ADODB.Command
cn.connectionstring = "Driver={SQL Server};Server=tean;Database=open;Uid=uuuu;pwd=cava"
cn.Open
If cn.State = adStateOpen Then
cm.ActiveConnection = cn
cm.CommandType = adCmdText
cm.CommandText = ""
For i = 2 To 300
If Range("K" + Trim(Str(i))).Value2 <> "" Then
cm.CommandText = cm.CommandText + Range("K" + Trim(Str(i))).Value2 + ";"
Else
Exit For
End If
Next
cm.Execute
Set cn = Nothing
Else
MsgBox ("Bağlantı Kurulamıyor!!")
End If
Range("K301").Select
End Sub

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub ÜÇYÜZLÜ_GRUPLARLA_AKTAR()
    
    Do While Sheets("Sayfa1").Range("A1") <> ""
        Sheets("Sayfa1").Range("A1:IV300").Copy Sheets("Sayfa2").Cells(65536, 1).End(3).Offset(1)
        Sheets("Sayfa2").Range("A1:IV" & Sheets("Sayfa2").Cells(65536, 1).End(3).Row).Interior.ColorIndex = 6
        Sheets("Sayfa2").Range("A1:IV" & Sheets("Sayfa2").Cells(65536, 1).End(3).Row).EntireRow.Delete
        Sheets("Sayfa1").Range("A1:IV300").EntireRow.Delete
    Loop
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[cavanoos]

Korhan Bey;

Teşekkür ederim.Tam istediğim gibi oldu...