Listedeki koşula göre düşeyara ile verileri aktarmak?

[voodoograph]

Merhaba arkadaşlar,

Öncelikle düşeyara ile ilgili birçok örnek olduğunu biliyorum fakat bir türlü istediğim örneğe ulaşamadım. Aşağıdaki makroyu denemeyi düşünüyorum. Ancak nasıl uyarlayabilirim ilgili sayfama.

///
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Set S1 = Sheets("LİSTE")
Set S2 = Sheets("İSTATİSTİK")
If Intersect(Target, S1.[a1:a20]) Is Nothing Then Exit Sub
For ara = 1 To 20
S1.Range("b" & ara) = WorksheetFunction.VLookup(S1.Range("a" & ara), S2.Range("f:h"), 2, 0)
S1.Range("c" & ara) = WorksheetFunction.VLookup(S1.Range("a" & ara), S2.Range("f:h"), 3, 0)
If S1.Range("a" & ara) = "" Then
S1.Range("a" & ara).Offset(0, 1) = ""
S1.Range("a" & ara).Offset(0, 2) = ""
End If
Next
End Sub
///


Eğer sadece fonksiyon ile çözülebilirse Liste sayfasında 60 yaşında büyük olanların düşeyara formülü ile İstatistik sayfasına nasıl uygulayabilirim.

Çok teşekkürler...

 

[Orion1]

Merhaba.
Burada soruyu 60 yaş diye sormuşsunuz dosyada 80.
Bend e80 yaşa göre yaptım.
Ekli dosyayı inceleyiniz.

Sub listele()
Dim sat As Long, i As Long, k As Byte
Sheets("LİSTE").Select
Sheets("İSTATİSTİK").Range("A2:C65536").ClearContents
sat = 2
For i = 2 To Cells(65536, "A").End(xlUp).Row
    If Cells(i, "C").Value >= 80 Then
        For k = 1 To 3
            Sheets("İSTATİSTİK").Cells(sat, k).Value = Cells(i, k).Value
        Next k
        sat = sat + 1
    End If
Next i
MsgBox "İŞLEM TAMAMLANDI.."
End Sub

 

[voodoograph]

Eline sağlık Orion2. istediğim gibi olmuş. Ancak küçük bir sorum var. Button olmadan sayfa kendine kendine sorgulayıp yenileyemez mi bilgileri?

 

[Orion1]

Eline sağlık Orion2. istediğim gibi olmuş. Ancak küçük bir sorum var. Button olmadan sayfa kendine kendine sorgulayıp yenileyemez mi bilgileri?

Merhaba.
Ekli dosyayı istediğiniz şekilde düzenledim.

 

[voodoograph]

Geç oldu ama yeniden eline sağlık Orion2...

Sistem belirtilen hücrelerle çok çok iyi çalışıyor ancak bu yaptığın formülde bir konuda esneklik sağlayamıyorum.

For döngüsünü A, B, C gibi sıralı sütunlar için kullanmışsın... Ben B, D, H sütunun kullanmayı denediğimde olmuyor. Bu konuda ne yapabiliriz?..

Kodlar aşağıdaki gibi problemsiz çalışıyor ancak sütun değiştiğinde herşey karışıyor. For döngüsünden öyle sanıyorum ki.

Sub listele()
Dim sat As Long, i As Long, k As Byte
Set S1 = Sheets("LİSTE")
Set S2 = Sheets("İSTATİSTİK")
S2.Range("A2:C500").ClearContents
sat = 2
For i = 2 To S1.Cells(500, "A").End(xlUp).Row
If S1.Cells(i, "C").Value >= 80 Then
For k = 1 To 3
S2.Cells(sat, k).Value = S1.Cells(i, k).Value
Next k
sat = sat + 1
End If
Next i
Set S1 = Nothing
End Sub


TEŞEKKÜRLER.

 

[Orion1]

For döngüsünü A, B, C gibi sıralı sütunlar için kullanmışsın... Ben B, D, H sütunun kullanmayı denediğimde olmuyor. Bu konuda ne yapabiliriz?..

BDE sütunlarından veri alınacakmı yoksa BDE sütunlarına veri yazılacakmı,yoksa her ikisi birdenmi olacak? onu belirtirseniz o şekilde yaparım.Ben sizin yollamış olduğunuz örnek dosyaya göre kodları yazmıştım.

 

[voodoograph]

Orion2 dosya ekte... Teşekkür ederim yeniden.

 

[Orion1]

Merhaba.
Dosyanız ekte.
ilk sayfadan çek ediyorsunuz isttistik sayfasında çek edilenler gözüküyor.

 

[voodoograph]

Yardımların için teşekkürler Orion2.

 

[Orion1]

Yardımların için teşekkürler Orion2.

Rica ederim.
İyi çalışmalar.

 

[voodoograph]

Yeniden merhaba, bu konuyu sürekli aktif tutuyorum özür dilerim ancak öğrenmem gereken birşey olduğunu düşünüyorum. Aşağıdaki kod da en basit açıklama ile;

If S1.Cells(i, "L").Value >= 60 Then satırından sonra
S2 A sütunu veri alanı = S1. B sütunu verileri
S2 B sütunu veri alanı = S1. C sütunu verileri
S2 C sütunu veri alanı = S1. L sütunu verileri

için nasıl bir kod kullanmalıyım?

///
Sub listele()
Dim sat As Long, i As Long, k As Byte
Set S1 = Sheets("BİREYSEL ÜYE LİSTESİ")
Set S2 = Sheets("YAŞ İSTATİSTİKLERİ")
S2.Range("A7:C500").ClearContents
sat = 7
For i = 6 To S1.Cells(500, "A").End(xlUp).Row
If S1.Cells(i, "L").Value >= 60 Then
For k = 1 To 3
S2.Cells(sat, k).Value = S1.Cells(i, k).Value
Next k
sat = sat + 1
End If
Next i
Set S1 = Nothing
End Sub
///

 

[voodoograph]

Aşağıdaki gibi yaptım ancak çalışmadı. Fikri olan var mı?


Sub listele()
Dim sat As Long, i As Long
Set S1 = Sheets("BİREYSEL ÜYE LİSTESİ")
Set S2 = Sheets("YAŞ İSTATİSTİKLERİ")
S2.Range("A7:C500").ClearContents
sat = 7
For i = 6 To S1.Cells(500, "A").End(xlUp).Row
If S1.Cells(i, "L").Value >= 60 Then
S2.Cells(sat, "A").Value = S1.Cells(i, "B").Value
S2.Cells(sat, "B").Value = S1.Cells(i, "C").Value
S2.Cells(sat, "C").Value = S1.Cells(i, "L").Value
sat = sat + 1
End If
Next i
Set S1 = Nothing
End Sub

 

[Orion1]

Merhaba.
Örnek dosya yollamanız ve üzerinde açıklama yapmanız cevap almanızı hızlandıracaktır.

 

[voodoograph]

Sorum, açıklamalı olarak ektedir. Teşekkür ederim.

 

[veyselemre]

Sub aktar()
    a = Sheets("LİSTE").Range("b6:f" & Sheets("LİSTE").[b65536].End(3).Row).Value
    Sheets("İSTATİSTİK").Select
    sat = 5
    Range("a6:c65536").ClearContents
    For x = 1 To UBound(a)
        If a(x, 5) > 60 Then
            sat = sat + 1
            Cells(sat, 1) = a(x, 1)
            Cells(sat, 2) = a(x, 2)
            Cells(sat, 3) = a(x, 5)
        End If
    Next x
End Sub

 

[voodoograph]

Ellerine sağlık veyselemre. İlk denemelerimde hiç bir sorun yaşamadım. İnşallah kullanabileceğim. Umarım bu örnek diğer arkadaşlarımızında işine yarayacaktır.

Teşekkür ederim.

Saygılar...