Sayfalardan verilerin sıralı çekilmesi

[mybluecat]

Merhaba,
Yapmak istediğim şey,Sayfa1 A1 hücresindeki veriyi B1 hücresi dolu ise Sayfa2 deki tabloda A1 e; Sayfa1 deki B2,B3 hücreleri boş B4 hücresi dolu ise A4 teki veriyi sayfa2 deki A2 hücresine atmak.
Yani veri girişi yaptığım sayfada veriler arasında boşluklar olsa dahi diğer sayfada çekilecek verilerin alt alta sıralanmasını istiyorum.Bir formülü veya kodu varsa yardım bekliyorum.
Ekte örnek dosya mevcut

 

[Emir Hüseyin Çoban]

. . .

NUMUNE NO 1 sayfasında hem E hemde F sütununda aynı satırda X olabilir mi.

. . .

 

[mybluecat]

Evet olabilir.Tüm hücreler de x işareti konabilir.Aşağıdaki kodu buldum fakat bu sadece ilk sütunda çalışıyor.Diğerlerinde nasıl çalışacağını bilmiyorum.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("E5:E60")) Is Nothing Then
sat = Target.Row
süt = Target.Column
aranan = Cells(sat, "d")
Set s1 = ThisWorkbook.Worksheets("parametre dağılım")
If WorksheetFunction.CountIf(Sheets("parametre dağılım").Range("c4:c59"), Cells(sat, "d")) = 0 And UCase(Cells(sat, süt)) = "X" Then
sonsatir = s1.Range("c65536").End(xlUp).Row + 1
s1.Cells(sonsatir, "c") = aranan
End If
End If
End Sub

 

[Emir Hüseyin Çoban]

. . .

parametre dağılım sayfasının kod bölümüne yapıştırın.
sayfaya girdiğinizde kodlar çalışır.

Private 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:D" & Rows.Count).ClearContents
For i = 5 To S1.Cells(Rows.Count, "D").End(3).Row

If UCase(S1.Cells(i, "E")) = "X" Then
sat1 = S2.Cells(Rows.Count, "C").End(3).Row + 1
S2.Cells(sat1, "C") = S1.Cells(i, "D")
End If

If UCase(S1.Cells(i, "F")) = "X" Then
sat2 = S2.Cells(Rows.Count, "D").End(3).Row + 1
S2.Cells(sat2, "D") = S1.Cells(i, "D")
End If

Next i
End Sub

. . .

 

[mybluecat]

Ekteki gibi bir hata alıyorum.Ne yapmalıyım? Gönderdiğiniz kod E ve F sütunlarının dışındaki diğer sütunlarda da çalışır mı?

 

[Emir Hüseyin Çoban]

. . .

Diğer sütunlarda çalışmaz.

Tablonuzu farklı kaydet yapıp. Makro içerebilen çalışma kitabı olarak kaydedin.


. . .

 

[mybluecat]

Diğer sütunlar için hiç mümkün değil mi yoksa bu kod için mi çalışmaz.Tüm tablo için buna ihtiyacım var.
If UCase(S1.Cells(i, "E")) = "X" Then
sat1 = S2.Cells(Rows.Count, "C").End(3).Row + 1
S2.Cells(sat1, "C") = S1.Cells(i, "D")
End If

If UCase(S1.Cells(i, "F")) = "X" Then
sat2 = S2.Cells(Rows.Count, "D").End(3).Row + 1
S2.Cells(sat2, "D") = S1.Cells(i, "D")
End If

If UCase(S1.Cells(i, "G")) = "X" Then
sat3 = S2.Cells(Rows.Count, "E").End(3).Row + 1
S2.Cells(sat3, "E") = S1.Cells(i, "D")
End If

Bu şekilde kodu devam ettirmeye çalıştım fakat işe yaramadı.

 

[Emir Hüseyin Çoban]

. . .

Baştan o durumu belirtseniz ona göre bir kodlama yapabilirdik.

Şu mantık ile çoğalta bilirsiniz.
G sütunu için

If UCase(S1.Cells(i, "G")) = "X" Then
sat3 = S2.Cells(Rows.Count, "E").End(3).Row + 1
S2.Cells(sat3, "E") = S1.Cells(i, "D")
End If

Ve temizleme alanını uzatmanız gerekiyor.

S2.Range("C4:[B][COLOR="Red"]V[/COLOR][/B]" & Rows.Count).ClearContents

. . .

 

[Emir Hüseyin Çoban]

. . .

Tüm tablo için şu kodları deneyin.

Private 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

. . .

 

[mybluecat]

Eline emeğine sağlık.Büyük bir problemimi çözdün.Çok teşekkür ederim.
Hakkını helal et.Kandilin mübarek olsun )