birden fazla sayfadaki verilerden seçim yapıp başka sayfaya aktarmak...

[inci55]

Merhaba,
sorunum belki basit ama yine de yardımlarınızı bekliyorum.

4 farklı sayfada da toplamda 3 sütundan oluşan verilerim var. Ben istiyorum ki bu dört farklı sayfada da; bir satırın c sütununda veri var ise aynı satırdaki b ve d sütunları ile beraber beşinci sayfaya kopyalayabileyim. ancak c sütununda her satırda veri yok aralarda boşluk var, boşluk olan satırlar gelmesin. beşinci sayfada bir düğme olsun basınca diğer sayfalardan bu kopyalama işlemini yapsın. formülle yapmaya çalıştım, bir türlü boş hücre olan satırların gelmesini engelleyemedim. yardımlarınızı bekliyorum...

 

[Husgvarna]

Merhaba,
sorunum belki basit ama yine de yardımlarınızı bekliyorum.

4 farklı sayfada da toplamda 3 sütundan oluşan verilerim var. Ben istiyorum ki bu dört farklı sayfada da; bir satırın c sütununda veri var ise aynı satırdaki b ve d sütunları ile beraber beşinci sayfaya kopyalayabileyim. ancak c sütununda her satırda veri yok aralarda boşluk var, boşluk olan satırlar gelmesin. beşinci sayfada bir düğme olsun basınca diğer sayfalardan bu kopyalama işlemini yapsın. formülle yapmaya çalıştım, bir türlü boş hücre olan satırların gelmesini engelleyemedim. yardımlarınızı bekliyorum...

Merhaba.
"ANA SAYFA" ya ekleyeceğiniz düğmeye aşağıdaki kodu yazın.

 Sub Düğme1_Tıklat()
[b4:d65000] = Clear
For a = 1 To 4
b = Sheets("Sayfa" & a).Cells(65000, 3).End(xlUp).Row
For d = 3 To b
c = Sheets("ANA SAYFA").Cells(65000, 2).End(xlUp).Row + 1
If Sheets("Sayfa" & a).Cells(d, 2) <> "" Then ad = Sheets("Sayfa" & a).Cells(d, 2).Value
If Sheets("Sayfa" & a).Cells(d, 3) <> "" Then
Cells(c, 2) = ad
Cells(c, 3) = Sheets("Sayfa" & a).Cells(d, 3)
Cells(c, 4) = Sheets("Sayfa" & a).Cells(d, 4)
End If
Next
Next
End Sub

 

[chngrcn]

Dosyanız ektedir, inceleyiniz.. saygılar..

Sub Düğme1_Tıklat() 'CODED BY CİHANGİR...
On Error Resume Next

Set s = Sheets("ANA SAYFA")
Set s1 = Sheets("SAYFA1")
Set s2 = Sheets("SAYFA2")
Set s3 = Sheets("SAYFA3")
Set s4 = Sheets("SAYFA4")

s.Range("B4:DM65536").ClearContents

a = s.[C65536].End(3).Row + 1
a1 = s1.[C65536].End(3).Row
a2 = s2.[C65536].End(3).Row
a3 = s3.[C65536].End(3).Row
a4 = s4.[C65536].End(3).Row

Application.ScreenUpdating = False

For i = 3 To a1
    
    If s1.Cells(i, 3).Value <> "" Then
        s.Cells(a, 2).Value = s1.Cells(i, 2)
        s.Cells(a, 3).Value = s1.Cells(i, 3)
        s.Cells(a, 4).Value = s1.Cells(i, 4)
        
            a = a + 1
    End If
    
    Next i

For y = 3 To a2
    
    If s2.Cells(y, 3).Value <> "" Then
        s.Cells(a, 2).Value = s1.Cells(y, 2)
        s.Cells(a, 3).Value = s1.Cells(y, 3)
        s.Cells(a, 4).Value = s1.Cells(y, 4)
        
            a = a + 1
    End If
    
    Next y
    
    
For z = 3 To a3
    
    If s2.Cells(z, 3).Value <> "" Then
        s.Cells(a, 2).Value = s1.Cells(z, 2)
        s.Cells(a, 3).Value = s1.Cells(z, 3)
        s.Cells(a, 4).Value = s1.Cells(z, 4)
        
            a = a + 1
    End If
    
    Next z

For x = 3 To a4
    
    If s2.Cells(x, 3).Value <> "" Then
        s.Cells(a, 2).Value = s1.Cells(x, 2)
        s.Cells(a, 3).Value = s1.Cells(x, 3)
        s.Cells(a, 4).Value = s1.Cells(x, 4)
        
            a = a + 1
    End If
    
    Next x

MsgBox " Aktarım işlemi başarı ile tamamlandı.. ", , ""
Application.ScreenUpdating = True

End Sub

 

[chngrcn]

benim ki de alternatif olsun.. saygılar..

 

[inci55]

teşekkürler hem işimi hallettiniz hem de kod sayesinde ileriye dönük faydalanabileceğim...