Farklı sayfalardan Makro ile sayfa sırasına göre veri çekmek

[mybluecat]

rivate Sub Worksheet_Activate()

Dim S1 As Worksheet: Set S1 = Sheets("NUMUNE NO 1")
Dim S2 As Worksheet: Set S2 = Sheets("parametre dağılım")

S2.Range("C4:V" & Rows.Count).ClearContents
son = S1.Cells(Rows.Count, "D").End(3).Row
For Each alan In S1.Range("E5:X" & son)
If UCase(alan) = "X" Then
sat = S2.Cells(Rows.Count, alan.Column - 2).End(3).Row + 1
S2.Cells(sat, alan.Column - 2) = S1.Cells(alan.Row, "D")
End If
Next

End Sub



Bu makro ile ekteki tabloda 1. sayfada (numune no 1) "x" işareti konuldukça sıralı bir şekilde 4. sayfaya (parametre) aktarılıyor.1. sayfa dolunca sırasıyla 2. ve 3. sayfalar da işaretleme yapacağım.Aynı şekilde 2. (numune no 2) ve 3. sayfalardaki (numune no 3) verilerin de 1. sayfadan gelen verilerin altında sıralı bir şekilde gelmesini istiyorum.
Yukarıdaki makroyu nasıl geliştirmem gerekir?Umarım karışık anlatmamışımdır.Ekteki tablo incelendiğinde daha iyi anlaşılır sanırım.

 

[Emir Hüseyin Çoban]

. . .

Sayfa sayısı 3 sabit mi yoksa 4-5 diye devam ediyor mu.

. . .

 

[Emir Hüseyin Çoban]

. . .

Yeni sayfa isimlerini array komutuna ilave edebilirsiniz.
s = Array("", "NUMUNE NO 1", "NUMUNE NO 2","Yeni Sayfa") gibi...

Private Sub Worksheet_Activate()
    s = Array("", "NUMUNE NO 1", "NUMUNE NO 2")
    
    Dim S2 As Worksheet: Set S2 = Sheets("parametre dağılım")
    
    S2.Range("C4:V" & Rows.Count).ClearContents
    
    For i = 1 To UBound(s)
        Set S1 = Sheets(s(i))
        son = S1.Cells(Rows.Count, "D").End(3).Row
        
        For Each alan In S1.Range("E5:X" & son)
            If UCase(alan) = "X" Then
                sat = S2.Cells(Rows.Count, alan.Column - 2).End(3).Row + 1
                S2.Cells(sat, alan.Column - 2) = S1.Cells(alan.Row, "D")
            End If
        Next
    Next i
    
End Sub

. . .

 

[mybluecat]

Hüseyin bey teşekkürler.Bir kaç gündür sizi biraz uğraştırdım.Hakkınızı helal edin.Elinize sağlık.

 

[mybluecat]

Özür dileyerek son bir şey sorsam.Sayfaları kapatmak istediğimde sürekli gizlilik uyarısı alıyorum.Bunu iptal etmek mümkün mü?

 

[Emir Hüseyin Çoban]

. . .

Aldığınız uyarının ekran görüntüsü eklerseniz inceleyelim.
Bende uyarı vermiyor.

. . .

 

[mybluecat]

Verdiği uyarı ekte mevcut.Bir de bu sabah deneme fırsatım oldu.dosyayı kapatıp tekrar açtığımda kod çalışmıyor.Örnek tabloyu da ekledim.

 

[Emir Hüseyin Çoban]

. . .

2. adımdaki etkinleştirmeyi yapın.

. . .

. . .

 

[mybluecat]

Sizin bu söylediğiniz yeri bulamadım.Bende 2007 versiyonu var.Onda farklı bir yer de olabilir mi?Bu etkinleştirmeyi yaparsam dosyayı kapatıp açtığımda kod çalışmaya devam edecek mi?

 

[Emir Hüseyin Çoban]

. . .

Bende uyarı verdiği halde kaydediyor ve kodları silmiyor.

Bu etkinleştirmeyi yaptıktan sonra hiç uyarı vermiyor, sorunsuz devam ediyor.

Uygun olduğumda Office 2007 sürümünde bakarım.

. . .

 

[mybluecat]

Cevabınızı bekleyeceğim.Dosyayı yeniden açtığım da kod var görünüyor fakat çalışmıyor.
Parametre sayfasında iken kod sayfasını açıyorum ve gönderdiğiniz kodu oraya yapıştırıyorum.Kayıt ederken sadece kaydet tuşuna basıyorum ve kod sayfasını kapatıyorum.Bu noktada bir hata yapıyor olabilirim belki.

 

[Emir Hüseyin Çoban]

. . .

Kırmızı alandaki tik işaretini kaldırın.

Sol üst köşe Excel Logosu > Seçenekler >

. . .

 

[mybluecat]

Cevabınızı bekleyeceğim.Dosyayı yeniden açtığım da kod var görünüyor fakat çalışmıyor.
Parametre sayfasında iken kod sayfasını açıyorum ve gönderdiğiniz kodu oraya yapıştırıyorum.Kayıt ederken sadece kaydet tuşuna basıyorum ve kod sayfasını kapatıyorum.Bu noktada bir hata yapıyor olabilirim belki.

 

[mybluecat]

Şimdi hem uyarı vermiyor hem de kapatıp açtığım da kod çalışmaya devam ediyor.Vakit ayırdığınız için teşekkür ederim.