Makro ile Bugünün tarihine göre veri alma

[demondivx]

Merhaba ekte olan örnek dosyamdaki gibi anasayfama diğer sayfalardaki verilerden önümüzdeki 7 gün içinde ödenmesi gereken senetleri getirmesini istiyorum ancak çok araştırdım ve uğraştım bir türlü halledemedim. konu ile yardımlarınızı rica eder, şimdiden teşekkür ederim.

(Office 2010 kullanmaktayım.)

 

[asi_kral]

Merhaba ekte olan örnek dosyamdaki gibi anasayfama diğer sayfalardaki verilerden önümüzdeki 7 gün içinde ödenmesi gereken senetleri getirmesini istiyorum ancak çok araştırdım ve uğraştım bir türlü halledemedim. konu ile yardımlarınızı rica eder, şimdiden teşekkür ederim.

(Office 2010 kullanmaktayım.)

Merhaba
Boş bir module oluşturup bu kodu kopyalayın ve deneyin.

Option Explicit
Sub senetleri_getir_1967()
'Konu       :   Günü gelen senetleri getir
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Skype      :   m.batu.1967
'Coder By   :   asi_kral_1967
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
Dim SAT As Long, SAY As Long, AÇ As Variant
Set S1 = Sheets("ANASAYFA"): Set S2 = Sheets("FİRMA1")
Set S3 = Sheets("FİRMA2")
Application.ScreenUpdating = False
AÇ = ActiveCell.Address
S1.Range("A2:F" & Rows.Count).ClearContents
With WorksheetFunction
SAT = S1.Range("A" & Rows.Count).End(xlUp).Row + 1
SAY = S2.Range("A" & Rows.Count).End(xlUp).Row
S2.Range("A1:F" & SAY).AutoFilter field:=6, Criteria1:=">=0", _
Operator:=xlAnd, Criteria2:="<=7"
If .Subtotal(3, S2.Range("A2:A" & SAY)) > 0 Then
S2.Range("A2:E" & SAY).Copy
S1.Range("A" & SAT).PasteSpecial (xlPasteValues)
End If
S2.Range("A1:F" & SAY).AutoFilter
SAT = S1.Range("A" & Rows.Count).End(xlUp).Row + 1
S3.Range("A1:F" & SAY).AutoFilter field:=6, Criteria1:=">=0", _
Operator:=xlAnd, Criteria2:="<=7"
If .Subtotal(3, S3.Range("A2:A" & SAY)) > 0 Then
S3.Range("A2:E" & SAY).Copy
S1.Range("A" & SAT).PasteSpecial (xlPasteValues)
End If
S2.Range("A1:F" & SAY).AutoFilter
End With
S1.Select
S1.Range(AÇ).Select
SAT = S1.Range("A" & Rows.Count).End(xlUp).Row
S1.Range("F2:F" & SAT) = "=B2-TODAY()"
S1.Range("F2:F" & SAT) = S1.Range("F2:F" & SAT).Value
S1.Range("A2:F" & SAT).Sort key1:=Range("F2"), order1:=xlAscending
MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "asi_kral_1967"
End Sub

Dosyanız Ekte.

 

[demondivx]

Tek kelimeyle harikasınız. Emeğinize sağlık çok teşekkür ederim...

 

[asi_kral]

Tek kelimeyle harikasınız. Emeğinize sağlık çok teşekkür ederim...

Kolay Gelsin.

 

[assenucler]

Teşekkürler üstadım...

 

[asi_kral]

Teşekkürler üstadım...

Kolay Gelsin.

 

[demondivx]

Kolay Gelsin.

Üstad seni son kez rahatsız ediyorum ben yeni bir sütun daha oluşturdum. yukarıdaki VBA koduna Örneğin K sütununda "ödenmedi" yazılı olanları getir kriterini eklemek istiyorum. Muhtemelen kolaydır ancak ben yeni başladığım için bilmiyorum. Epey bir uğraştım ama halledemedim. Yardımların için ne kadar teşekkür etsem azdır. Şimdiden teşekkürler...

 

[asi_kral]

Üstad seni son kez rahatsız ediyorum ben yeni bir sütun daha oluşturdum. yukarıdaki VBA koduna Örneğin K sütununda "ödenmedi" yazılı olanları getir kriterini eklemek istiyorum. Muhtemelen kolaydır ancak ben yeni başladığım için bilmiyorum. Epey bir uğraştım ama halledemedim. Yardımların için ne kadar teşekkür etsem azdır. Şimdiden teşekkürler...

Dosyanızı ekleyin ve içinde şu şekilde olmalı diye açıklama ekleyin. olması gereken verileri de yazın bakalım yapabilirsek yaparız.

 

[demondivx]

Dosyanızı ekleyin ve içinde şu şekilde olmalı diye açıklama ekleyin. olması gereken verileri de yazın bakalım yapabilirsek yaparız.

Örnek dosya ekte mevcuttur. yapmak istediğim anasayfada durumu ödenmedi olanları göreyim sadece... şimdiden teşekkür ederim. Ayrıca kodları biraz değiştirdim. örnek kodlardan baka baka biraz biraz öğreniyoruz sizlerden. Tekrar teşekkürler...

 

[asi_kral]

Örnek dosya ekte mevcuttur. yapmak istediğim anasayfada durumu ödenmedi olanları göreyim sadece... şimdiden teşekkür ederim. Ayrıca kodları biraz değiştirdim. örnek kodlardan baka baka biraz biraz öğreniyoruz sizlerden. Tekrar teşekkürler...

Merhaba
Kodu bununla değiştirip dener misiniz_?

Option Explicit
Sub Auto_Open()
'Konu       :   Günü gelen senetleri getir
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Skype      :   m.batu.1967
'Coder By   :   asi_kral_1967
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
Dim SAT As Long, SAY As Long, AÇ As Variant
Set S1 = Sheets("ANASAYFA"): Set S2 = Sheets("FİRMA1")
Set S3 = Sheets("FİRMA2")
Application.ScreenUpdating = False
AÇ = ActiveCell.Address
S1.Range("B2:K" & Rows.Count).ClearContents
With WorksheetFunction
SAT = S1.Range("B" & Rows.Count).End(xlUp).Row + 1
SAY = S2.Range("B" & Rows.Count).End(xlUp).Row
S2.Range("B1:K" & SAY).AutoFilter field:=6, Criteria1:=">=0", _
Operator:=xlAnd, Criteria2:="<=7"
S2.Range("B1:K" & SAY).AutoFilter field:=10, Criteria1:="ÖDENMEDİ"
If .Subtotal(3, S2.Range("B2:B" & SAY)) >= 0 Then
S2.Range("B2:K" & SAY).Copy
S1.Range("B" & SAT).PasteSpecial (xlPasteValues)
End If
S2.Range("B1:K" & SAY).AutoFilter
SAT = S1.Range("B" & Rows.Count).End(xlUp).Row + 1
SAY = S3.Range("B" & Rows.Count).End(xlUp).Row
S3.Range("B1:K" & SAY).AutoFilter field:=6, Criteria1:=">=0", _
Operator:=xlAnd, Criteria2:="<=7"
S3.Range("B1:K" & SAY).AutoFilter field:=10, Criteria1:="ÖDENMEDİ"
If .Subtotal(3, S3.Range("B2:B" & SAY)) >= 0 Then
S3.Range("B2:K" & SAY).Copy
S1.Range("B" & SAT).PasteSpecial (xlPasteValues)
End If
S3.Range("B1:K" & SAY).AutoFilter
End With
S1.Select
S1.Range(AÇ).Select
SAT = S1.Range("B" & Rows.Count).End(xlUp).Row
S1.Range("J2:J" & SAT) = "=I2-TODAY()"
S1.Range("J2:J" & SAT) = S1.Range("J2:J" & SAT).Value
S1.Range("B2:J" & SAT).Sort key1:=Range("J2"), order1:=xlAscending
MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "Yenileme işlemi"
End Sub

Dosyanız Ektedir.