İstenen şartlarda veri aktarımı

[mlhtrn]

ekte eklediğim dosyada sayfa 1 e sayfa 2 den yeşil kısımları sayfa 3 den de mavi kısımları kopyala yapıştır yapacak bir kod arıyorum. Ama aynı sütunları aynı sütunun altına önce 2 den sonra 3 den gelecek şekilde bir şartım var.

 

[N.Ziya Hiçdurmaz]

yanıt

Sub aktar()
Dim sat As Integer
Dim sut As Integer
Dim s As Integer
    For sut = 1 To Cells(1, Columns.Count).End(xlToRight).Column
    s = Sayfa1.Cells(Rows.Count, sut).End(xlUp).Row + 1
    For sat = 1 To Cells(Rows.Count, "a").End(xlUp).Row
        If Sayfa2.Cells(sat, sut).Interior.ColorIndex = 10 Then
            Sayfa2.Cells(sat, sut).Copy Sayfa1.Cells(s, sut)
            s = s + 1
        End If
    Next
    Next
    '
    For sut = 1 To Cells(1, Columns.Count).End(xlToRight).Column
    s = Sayfa1.Cells(Rows.Count, sut).End(xlUp).Row + 1
    For sat = 1 To Cells(Rows.Count, "a").End(xlUp).Row
        If Sayfa3.Cells(sat, sut).Interior.ColorIndex = 33 Then
            Sayfa3.Cells(sat, sut).Copy Sayfa1.Cells(s, sut)
            s = s + 1
        End If
    Next
    Next
End Sub

 

[mlhtrn]

ziya bey zaman ve emek ayırdığınız için öncelikle teşekkürlerimi sunarım. formülde sanırım küçük bir yanlışlık var çünkü 2 sayfadaki verileri kopyalamıyor

 

[N.Ziya Hiçdurmaz]

yanıt

Bir sorun görünmüyor.

 

[werty123]

anasayfa olarak verileri girdiğimizde diğer sayfalara bilgileri aktarmak istiyorum.yardımlarınız için teşekkürler.
örnek;
sayfa1 yazdığım adı soyadı tc adres tel bilgilerini kişilere ait sayfalara aktarsın

 

[mlhtrn]

ziya bey sanırım burada sayfa 2 ve 3 de eğer o renkte hücre varsa kopyala gibi bir işlem yapıyor benim hücreleri renklendirme amacım anlaşılabilirlik olsun diyeydi normalde renklendirme olmayan sayfalardan o sutünları çekmem lazım

 

[mlhtrn]

ziya bey sanırım burada sayfa 2 ve 3 de eğer o renkte hücre varsa kopyala gibi bir işlem yapıyor benim hücreleri renklendirme amacım anlaşılabilirlik olsun diyeydi normalde renklendirme olmayan sayfalardan o sutünları çekmem lazım

 

[N.Ziya Hiçdurmaz]

yanıt

Bu şekil deneyiniz.

Sub aktar()
Dim sat As Integer
Dim sut As Integer
Dim s As Integer
    Sayfa2.Range("d:d,f:f,g:g,ı:ı").Interior.ColorIndex = 10
    Sayfa3.Range("d:d,e:e,h:h,l:l").Interior.ColorIndex = 33
    For sut = 1 To Cells(1, Columns.Count).End(xlToRight).Column
    s = Sayfa1.Cells(Rows.Count, sut).End(xlUp).Row + 1
    For sat = 1 To Cells(Rows.Count, "a").End(xlUp).Row
        If Sayfa2.Cells(sat, sut).Interior.ColorIndex = 10 Then
            Sayfa2.Cells(sat, sut).Copy Sayfa1.Cells(s, sut)
            s = s + 1
        End If
    Next
    Next
    '
    For sut = 1 To Cells(1, Columns.Count).End(xlToRight).Column
    s = Sayfa1.Cells(Rows.Count, sut).End(xlUp).Row + 1
    For sat = 1 To Cells(Rows.Count, "a").End(xlUp).Row
        If Sayfa3.Cells(sat, sut).Interior.ColorIndex = 33 Then
            Sayfa3.Cells(sat, sut).Copy Sayfa1.Cells(s, sut)
            s = s + 1
        End If
    Next
    Next
    Sayfa1.Range("a:p").Interior.ColorIndex = xlNone
    Sayfa2.Range("d:d,f:f,g:g,ı:ı").Interior.ColorIndex = xlNone
    Sayfa3.Range("d:d,e:e,h:h,l:l").Interior.ColorIndex = xlNone
End Sub

 

[mlhtrn]

Kırmızı yazılı kısımda hata veriyor Ziya bey...

Sub aktar()
Dim sat As Integer
Dim sut As Integer
Dim s As Integer
Sayfa2.Range("d:d,f:f,g:g,ı:ı").Interior.ColorIndex = 10
Sayfa3.Range("d:d,e:e,h:h,l:l").Interior.ColorIndex = 33
For sut = 1 To Cells(1, Columns.Count).End(xlToRight).Column
s = Sayfa1.Cells(Rows.Count, sut).End(xlUp).Row + 1 For sat = 1 To Cells(Rows.Count, "a").End(xlUp).Row
If Sayfa2.Cells(sat, sut).Interior.ColorIndex = 10 Then
Sayfa2.Cells(sat, sut).Copy Sayfa1.Cells(s, sut)
s = s + 1
End If
Next
Next
'
For sut = 1 To Cells(1, Columns.Count).End(xlToRight).Column
s = Sayfa1.Cells(Rows.Count, sut).End(xlUp).Row + 1
For sat = 1 To Cells(Rows.Count, "a").End(xlUp).Row
If Sayfa3.Cells(sat, sut).Interior.ColorIndex = 33 Then
Sayfa3.Cells(sat, sut).Copy Sayfa1.Cells(s, sut)
s = s + 1
End If
Next
Next
Sayfa1.Range("a").Interior.ColorIndex = xlNone
Sayfa2.Range("d:d,f:f,g:g,ı:ı").Interior.ColorIndex = xlNone
Sayfa3.Range("d:d,e:e,h:h,l:l").Interior.ColorIndex = xlNone
End Sub

 

[N.Ziya Hiçdurmaz]

yanıt

Ekli dosyayı inceleyiniz.

 

[mlhtrn]

Ziya bey öncelikle her sorumu cevaplandırdığınız için teşekürler. Üzülerek söylemekteyim 1 sorunum daha var sayfa 2 ve sayfa 3 deki D kolonuna 15-20 arası sayı ekledim aşaya doğru . Makroyu çalıştır dediğimde eklemiş olduklarımdan 2 tanesini falan aktardı sebebini anlayamadım yani neden hepsini aktarmıyor ki ?acaba burada ki hata nedir?