• DİKKAT

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

makro ile ekstre almak

kod:

Kod: 
Sub verial()


Dim baslangıc, bitis, aranan1, bulunan1, bulunan2
baslangıc = Sheets("ekstre").Cells(1, "b").Value
bitis = Sheets("ekstre").Cells(1, "d").Value
aranan1 = Sheets("ekstre").Cells(2, "b").Value

Sheets("ekstre").Range("A4:e" & Rows.Count).ClearContents

If IsDate(baslangıc) <> True Then Exit Sub
If IsDate(bitis) <> True Then Exit Sub

sat = 4
say1 = 0
say2 = 0

For j = 2 To Sheets("veri").Cells(Rows.Count, "A").End(xlUp).Row

If CDate(baslangıc) > CDate(Sheets("veri").Cells(j, "A").Value) Then
bulunan1 = Sheets("veri").Cells(j, "b").Value
bulunan2 = Sheets("veri").Cells(j, "c").Value

If bulunan1 = aranan1 Then
say1 = say1 + CDbl(Sheets("veri").Cells(j, "e").Value)
veri1 = CDbl(Sheets("veri").Cells(j, "a").Value)
End If

If bulunan2 = aranan1 Then
say2 = say2 + CDbl(Sheets("veri").Cells(j, "f").Value)
veri2 = Sheets("veri").Cells(j, "d").Value
End If

End If
Next



Sheets("ekstre").Cells(sat, "a").Value = veri1
Sheets("ekstre").Cells(sat, "b").Value = "devir"
Sheets("ekstre").Cells(sat, "c").Value = say1
Sheets("ekstre").Cells(sat, "d").Value = say2
Sheets("ekstre").Cells(sat, "e").Value = say1 - say2
'Sheets("ekstre").Cells(sat, "e").Value = "=RC[-2]-RC[-1]"
sat = sat + 1


For i = 2 To Sheets("veri").Cells(Rows.Count, "A").End(xlUp).Row
bulunan1 = Sheets("veri").Cells(i, "b").Value
bulunan2 = Sheets("veri").Cells(i, "c").Value

If CDate(baslangıc) <= CDate(Sheets("veri").Cells(i, "A").Value) _
And CDate(bitis) >= CDate(Sheets("veri").Cells(i, "A").Value) Then

If bulunan1 = aranan1 Then
Sheets("ekstre").Cells(sat, "a").Value = Sheets("veri").Cells(i, "A").Value
Sheets("ekstre").Cells(sat, "b").Value = Sheets("veri").Cells(i, "d").Value
Sheets("ekstre").Cells(sat, "c").Value = Sheets("veri").Cells(i, "f").Value
'Sheets("ekstre").Cells(sat, "e").Value = Sheets("ekstre").Cells(sat - 1, "e").Value - Sheets("ekstre").Cells(sat, "d").Value
Sheets("ekstre").Cells(sat, "e").Value = "=R[-1]C+RC[-2]-RC[-1]"

sat = sat + 1
End If

If bulunan2 = aranan1 Then
Sheets("ekstre").Cells(sat, "a").Value = Sheets("veri").Cells(i, "A").Value
Sheets("ekstre").Cells(sat, "b").Value = Sheets("veri").Cells(i, "d").Value
Sheets("ekstre").Cells(sat, "d").Value = Sheets("veri").Cells(i, "f").Value
Sheets("ekstre").Cells(sat, "e").Value = "=R[-1]C+RC[-2]-RC[-1]"
'Sheets("ekstre").Cells(sat, "e").Value = Sheets("ekstre").Cells(sat - 1, "e").Value - Sheets("ekstre").Cells(sat, "d").Value
sat = sat + 1
End If


End If

Next


MsgBox "işlem tamam"
End Sub
 
Merhaba.

Sayın ÖZDEMİR'in müsadesiyle; ben de anladığımı ileteyim dedim.
Bir de aşağıdaki kod blokunu dener misiniz? Belki bu fal tutar.
Rich (BB code): 
Sub BARAN_EKSTRE_DENEME()
Set v = Sheets("veri"): Set e = Sheets("ekstre")
If e.[B1] > e.[D1] Then
    MsgBox "Ekstre başlangıç tarihi, bitiş tarihinden büyük olamaz!", vbCritical
    Exit Sub
End If
e.Range("A4:E" & Rows.Count).Clear
Application.ScreenUpdating = False
If v.AutoFilterMode = True Then v.AutoFilterMode = False
vs = v.Cells(Rows.Count, 1).End(3).Row
    With v.Range("G2:G" & vs)
        .Formula = "=IF(AND(A2<ekstre!$b$1,B2=ekstre!$b$2),""bo"",IF(AND(a2<ekstre!$b$1,c2=ekstre!$b$2),""ao""," & _
                    "IF(a2>ekstre!$d$1,"""",IF(b2=ekstre!$b$2,""bs"",IF(c2=ekstre!$b$2,""as"","""")))))"
        .Value = .Value
    End With
For ey = 1 To 2
    For boal = 1 To 2
        If v.AutoFilterMode = True Then v.AutoFilterMode = False
        If ey = 1 Then
            If boal = 1 Then kriter = "bo": sut = 5
            If boal = 2 Then kriter = "ao": sut = 6
            v.Range("A1:G" & vs).AutoFilter Field:=7, Criteria1:="=" & kriter
            topl = Evaluate("=SUBTOTAL(9,veri!" & Left(Cells(1, sut).Address(0, 0), 1) & "2:" & _
                                            Left(Cells(1, sut).Address(0, 0), 1) & vs & ")")
            e.[A4] = e.[B1] - 1: e.[B4] = "DEVİR": e.Cells(4, sut - 2) = topl
        ElseIf ey = 2 Then
            v.Range("A1:G" & vs).AutoFilter Field:=7, Criteria1:="=" & "bs", Operator:=xlOr, Criteria2:="=" & "as"
                If v.Cells(Rows.Count, 1).End(3).Row = 1 Then Exit For
                For Each hcr In v.Range("G2:G" & vs).SpecialCells(xlCellTypeVisible)
                    esat = e.Cells(Rows.Count, 1).End(3).Row + 1
                        e.Cells(esat, 1) = hcr.Offset(0, -6): e.Cells(esat, 2) = hcr.Offset(0, -3)
                    If hcr = "as" Then e.Cells(esat, 4) = hcr.Offset(0, -1)
                    If hcr = "bs" Then e.Cells(esat, 3) = hcr.Offset(0, -2)
                Next
                Exit For
        End If
    Next
Next
If v.AutoFilterMode = True Then v.AutoFilterMode = False
    e.[E4] = e.[C4] - e.[D4]
    With e.Range("E4:E" & e.Cells(Rows.Count, 1).End(3).Row)
        .Formula = "=SUM(E3,C4)-D4": .Value = .Value
    End With
v.[G:G].Clear
eson = e.Cells(Rows.Count, 1).End(3).Row
e.Range("A4:A" & eson).NumberFormat = "d/mm/yyyy"
e.Range("C4:E" & eson).NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
e.Range("A4:E" & eson).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation
End Sub
 
Son düzenleme:
Ne demek Müsade sizin Ömer Bey Soruyu anlayana kadar 20 mesaj olmuş.
21 nolu mesajdaki kod sizinki ile aynı mahiyette

Ne kadar alternatif olursa o kadar bilgi demek.
 
Ömer hocam tam istediğim gibi olmuş gerçekten. Sn. Halit hocama ve size sonsuz teşekkürlerimi sunuyorum, iyi ki varsınız...
 
Kendi adıma eyvallah diyorum.
Sayın ÖZDEMİR'e de nezaketi dolayısıyla teşekkürler.
Benim tercihim formül+filtre yöntemi oldu.
Bilgiyi paylaşarak çoğaltmaya ahdetmiş forum üyeleri olarak her zaman buralardayız.
Alternatif iyidir.
.
 
Burada bir şeyler eksik gibi geliyor bana
Örnek dosyanızda exstre sayfasında ilk tarih B2 hücresinde 13.09.2018 yazıyor bunu 11.09.2018 yapınca devir olmadığından hesaplamalar doğru vermiyor bu ihtimali de gözönünde bulundurdunuzmu
 
Son düzenleme:
Tekrar merhaba,
-- Sayın ÖZDEMİR'in uyarısı üzerine fark ettiğim, başlangıç tarihi olarak eski bir tarih girilmesi
ihtimaliyle ilgili olarak mavi renklendirdiğim satırı ekledim,
-- Aynı durum ile ilgili olarak da matematiksel hata gidermek için kırmızı renklediğim kısımları değiştirdim.
-- Ayrıca başlangıç ve bitiş tarihi tutarsızlığı ile ilgili olarak da yeşil satırları ekledim.
Sayfayı yenileyerek önceki cevabıma tekrar bakıp yeni halini kullanmanızı hatırlatmak isterim.

Sayın ÖZDEMİR, son cevabınızı anlamadım. Hatalı olan nedir acaba?
.
 
Son düzenleme:
Buda benim yazdığım kod tarihler yer değiştirsede kod çalışır.

Kod: 
Sub verial()


Dim baslangıc, bitis, aranan1, bulunan1, bulunan2
Dim deg1, deg2, yer1, yer2
baslangıc = Sheets("ekstre").Cells(1, "b").Value
bitis = Sheets("ekstre").Cells(1, "d").Value
aranan1 = Sheets("ekstre").Cells(2, "b").Value

Sheets("ekstre").Range("A4:e" & Rows.Count).ClearContents

If IsDate(baslangıc) <> True Then Exit Sub
If IsDate(bitis) <> True Then Exit Sub

deg1 = CDate(baslangıc)
deg2 = CDate(bitis)

If deg1 <= deg2 Then
yer1 = CDate(baslangıc)
yer2 = CDate(bitis)
Else
yer2 = CDate(baslangıc)
yer1 = CDate(bitis)
End If

sat = 4
say1 = 0
say2 = 0

For j = 2 To Sheets("veri").Cells(Rows.Count, "A").End(xlUp).Row

If yer1 > CDate(Sheets("veri").Cells(j, "A").Value) Then
bulunan1 = Sheets("veri").Cells(j, "b").Value
bulunan2 = Sheets("veri").Cells(j, "c").Value

If bulunan1 = aranan1 Then
say1 = say1 + CDbl(Sheets("veri").Cells(j, "e").Value)
veri1 = CDbl(Sheets("veri").Cells(j, "a").Value)
End If

If bulunan2 = aranan1 Then
say2 = say2 + CDbl(Sheets("veri").Cells(j, "f").Value)
veri2 = Sheets("veri").Cells(j, "d").Value
End If

End If
Next



Sheets("ekstre").Cells(sat, "a").Value = veri1
Sheets("ekstre").Cells(sat, "b").Value = "devir"
Sheets("ekstre").Cells(sat, "c").Value = say1
Sheets("ekstre").Cells(sat, "d").Value = say2
Sheets("ekstre").Cells(sat, "e").Value = say1 - say2
'Sheets("ekstre").Cells(sat, "e").Value = "=RC[-2]-RC[-1]"
sat = sat + 1

For i = 2 To Sheets("veri").Cells(Rows.Count, "A").End(xlUp).Row
bulunan1 = Sheets("veri").Cells(i, "b").Value
bulunan2 = Sheets("veri").Cells(i, "c").Value

If yer1 <= CDate(Sheets("veri").Cells(i, "A").Value) _
And yer2 >= CDate(Sheets("veri").Cells(i, "A").Value) Then

If bulunan1 = aranan1 Then
Sheets("ekstre").Cells(sat, "a").Value = Sheets("veri").Cells(i, "A").Value
Sheets("ekstre").Cells(sat, "b").Value = Sheets("veri").Cells(i, "d").Value
Sheets("ekstre").Cells(sat, "c").Value = Sheets("veri").Cells(i, "f").Value
'Sheets("ekstre").Cells(sat, "e").Value = Sheets("ekstre").Cells(sat - 1, "e").Value - Sheets("ekstre").Cells(sat, "d").Value
Sheets("ekstre").Cells(sat, "e").Value = "=R[-1]C+RC[-2]-RC[-1]"

sat = sat + 1
End If

If bulunan2 = aranan1 Then
Sheets("ekstre").Cells(sat, "a").Value = Sheets("veri").Cells(i, "A").Value
Sheets("ekstre").Cells(sat, "b").Value = Sheets("veri").Cells(i, "d").Value
Sheets("ekstre").Cells(sat, "d").Value = Sheets("veri").Cells(i, "f").Value
Sheets("ekstre").Cells(sat, "e").Value = "=R[-1]C+RC[-2]-RC[-1]"
'Sheets("ekstre").Cells(sat, "e").Value = Sheets("ekstre").Cells(sat - 1, "e").Value - Sheets("ekstre").Cells(sat, "d").Value
sat = sat + 1
End If


End If

Next


MsgBox "işlem tamam"
End Sub
 
Benim açımdan ciddi bir sıkıntı yoktu açıkçası, ancak her ikinizin de kodları tam olarak kullanılabilir şekilde. Emeğinize sağlık..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst