• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Şart Bağlı veri alma

C

ckarabacak

Altın Üye
Katılım
12 Ocak 2010
Mesajlar
369
Excel Vers. ve Dili
Excel 2010
Merhaba Ekte tabloda tarih koşulu oluşturarak ilgili sayfadan verileri getirmek istiyorum. Yardımlarınız için şimdiden teşekkür ederim
 

Ekli dosyalar

Merhaba.

Belgede mevcut verilere ve Sayfa2'deki ay seçimine göre olması gereken sonucu elle kopyala-yapıştır yaparak örneklendirmenizde yarar var.
Sayfalardaki başlıklar tam olarak aynı olmadığından, hangi sütun verisinin hangi sütuna aktarılacağını netleştirirseniz daha hızlı sonuca ulaşırsınız.
.
 
Merhaba Ömer Bey

Alakanız için teşekkür ederim .

Ekte yer almaktadır.
 

Ekli dosyalar

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz:

Kod: 
Sub aktar()

Set s1 = Sheets("2018")
Set s2 = Sheets("Sayfa2")

    s1.[B18].AutoFilter
    s1.[B18].AutoFilter

son = s1.Cells(Rows.Count, "C").End(3).Row
eskialacak = WorksheetFunction.Max(9, s2.Cells(Rows.Count, "B").End(3).Row)
eskiborç = WorksheetFunction.Max(9, s2.Cells(Rows.Count, "L").End(3).Row)
s2.Range("B9:I" & eskialacak).ClearContents
s2.Range("L9:S" & eskiborç).ClearContents

yeniborç = 9
yenialacak = 9

For i = 19 To son
    If s1.Cells(i, "C") = s2.[B2] Then
        If s1.Cells(i, "E") = "Alacak" Then
            s2.Cells(yenialacak, "B") = s1.Cells(i, "D")
            s2.Cells(yenialacak, "C") = s1.Cells(i, "G")
            s2.Cells(yenialacak, "D") = s1.Cells(i, "F")
            s2.Cells(yenialacak, "E") = s1.Cells(i, "H")
            If s1.Cells(i, "J") = "TL" Then s2.Cells(yenialacak, "F") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "EURO" Then s2.Cells(yenialacak, "G") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "USD" Then s2.Cells(yenialacak, "H") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "STERLİN" Then s2.Cells(yenialacak, "I") = s1.Cells(i, "I")
            yenialacak = yenialacak + 1
        ElseIf s1.Cells(i, "E") = "Borç" Then
            s2.Cells(yeniborç, "L") = s1.Cells(i, "D")
            s2.Cells(yeniborç, "M") = s1.Cells(i, "G")
            s2.Cells(yeniborç, "N") = s1.Cells(i, "F")
            s2.Cells(yeniborç, "O") = s1.Cells(i, "H")
            If s1.Cells(i, "J") = "TL" Then s2.Cells(yeniborç, "P") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "EURO" Then s2.Cells(yeniborç, "Q") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "USD" Then s2.Cells(yeniborç, "R") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "STERLİN" Then s2.Cells(yeniborç, "S") = s1.Cells(i, "I")
            yeniborç = yeniborç + 1
        End If
    End If
Next

End Sub
 
Eğer B2 değiştiğinde otomatik yüklenmesini istiyorsanız aşağıdaki kodları Sayfa2'nin kod bölümüne (sayfa ismine sağ tıklayıp kod Görüntüle deyince açılan sayfaya) yapıştırıp deneyin:
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2]) Is Nothing Then Exit Sub
Set s1 = Sheets("2018")
Set s2 = Sheets("Sayfa2")

    s1.[B18].AutoFilter
    s1.[B18].AutoFilter

son = s1.Cells(Rows.Count, "C").End(3).Row
eskialacak = WorksheetFunction.Max(9, s2.Cells(Rows.Count, "B").End(3).Row)
eskiborç = WorksheetFunction.Max(9, s2.Cells(Rows.Count, "L").End(3).Row)
s2.Range("B9:I" & eskialacak).ClearContents
s2.Range("L9:S" & eskiborç).ClearContents

yeniborç = 9
yenialacak = 9

For i = 19 To son
    If s1.Cells(i, "C") = s2.[B2] Then
        If s1.Cells(i, "E") = "Alacak" Then
            s2.Cells(yenialacak, "B") = s1.Cells(i, "D")
            s2.Cells(yenialacak, "C") = s1.Cells(i, "G")
            s2.Cells(yenialacak, "D") = s1.Cells(i, "F")
            s2.Cells(yenialacak, "E") = s1.Cells(i, "H")
            If s1.Cells(i, "J") = "TL" Then s2.Cells(yenialacak, "F") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "EURO" Then s2.Cells(yenialacak, "G") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "USD" Then s2.Cells(yenialacak, "H") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "STERLİN" Then s2.Cells(yenialacak, "I") = s1.Cells(i, "I")
            yenialacak = yenialacak + 1
        ElseIf s1.Cells(i, "E") = "Borç" Then
            s2.Cells(yeniborç, "L") = s1.Cells(i, "D")
            s2.Cells(yeniborç, "M") = s1.Cells(i, "G")
            s2.Cells(yeniborç, "N") = s1.Cells(i, "F")
            s2.Cells(yeniborç, "O") = s1.Cells(i, "H")
            If s1.Cells(i, "J") = "TL" Then s2.Cells(yeniborç, "P") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "EURO" Then s2.Cells(yeniborç, "Q") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "USD" Then s2.Cells(yeniborç, "R") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "STERLİN" Then s2.Cells(yeniborç, "S") = s1.Cells(i, "I")
            yeniborç = yeniborç + 1
        End If
    End If
Next

End Sub
 
Arkadaşlar
Zihninize emeğinize sağlık
Çok teşekkür ederim
 
Üstad Tekrardan Merhabalar

Tabloyu ekte ki gibi tekrar revize edebilir miyiz. Mümkünse tarih sıralamasına göre Uğraştım fakat beceremedim :)

Teşekkür ederim
 

Ekli dosyalar

Aşağıdaki kodları sayfa2'nin adına sağ tıklayıp kod görüntüle deyince açılan sayfaya yapıştırın. Öncesinde mevcut kodları silin:

Kod: 
If Intersect(Target, [B2]) Is Nothing Then Exit Sub
Set s1 = Sheets("2018")
Set s2 = Sheets("Sayfa2")

    s1.[B18].AutoFilter
    s1.[B18].AutoFilter

son = s1.Cells(Rows.Count, "C").End(3).Row

listesonu = WorksheetFunction.Max(9, s2.Cells(Rows.Count, "B").End(3).Row)

s2.Range("B9:O" & listesonu).ClearContents

For i = 19 To son
    If s1.Cells(i, "C") = s2.[B2] Then 'dönem kontrolü
        yeni = WorksheetFunction.Max(9, s2.Cells(Rows.Count, "B").End(3).Row + 1) 'ilk boş satırı belirleme
        
        s2.Cells(yeni, "B") = s1.Cells(i, "D") 'tarih
        s2.Cells(yeni, "C") = s1.Cells(i, "G") 'açıklama
        s2.Cells(yeni, "D") = s1.Cells(i, "F") 'tür
        s2.Cells(yeni, "E") = s1.Cells(i, "H") 'evrak no
        
        If s1.Cells(i, "E") = "Alacak" Then
            If s1.Cells(i, "J") = "TL" Then s2.Cells(yeni, "G") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "EURO" Then s2.Cells(yeni, "H") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "USD" Then s2.Cells(yeni, "I") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "STERLİN" Then s2.Cells(yeni, "J") = s1.Cells(i, "I")
        ElseIf s1.Cells(i, "E") = "Borç" Then
            If s1.Cells(i, "J") = "TL" Then s2.Cells(yeni, "L") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "EURO" Then s2.Cells(yeni, "M") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "USD" Then s2.Cells(yeni, "N") = s1.Cells(i, "I")
            If s1.Cells(i, "J") = "STERLİN" Then s2.Cells(yeni, "O") = s1.Cells(i, "I")
        End If
    End If
Next
    
    bitiş = s2.Cells(Rows.Count, "B").End(3).Row

    s2.Sort.SortFields.Clear
    s2.Sort.SortFields.Add Key:=Range("B9:B" & bitiş) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    s2.Sort.SortFields.Add Key:=Range("E9:E" & bitiş) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With s2.Sort
        .SetRange Range("B8:O" & bitiş)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    s2.Range("B9:B" & i).NumberFormat = "dd/mm/yyyy"
    With s2.Range("B9:B" & i)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With s2.Range("E9:E" & i)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With s2.Range("C9:D" & i)
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With s2.Range("B9:O" & i)
        .VerticalAlignment = xlCenter
    End With
    
    s2.Range("G9:O" & i).NumberFormat = "#,##0.00"

    s2.Columns("B:E").EntireColumn.AutoFit
    s2.Columns("G:J").EntireColumn.AutoFit
    s2.Columns("L:O").EntireColumn.AutoFit
End Sub
 
Çok teşekkür ederim cevap yazdığınızdan beri uğraşıyorum bir türlü tutmadı gitti :) ilk yazdığınız kod ile karşılaştırınca neyi eksik yaptığımı gördüm eline sağlık üstadım
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst