• DİKKAT

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

Bugüne Ait Kayıtları Başka Bir Sayfaya Aktarma

Y

yerbakili

Destek Ekibi
Destek Ekibi
Katılım
12 Mayıs 2009
Mesajlar
174
Excel Vers. ve Dili
Office 2003
Merhaba,

Bir konuda takıldım ve yardımınıza ihtiyacım var. Ekteki dosyadan da anlaşılacağı gibi, kayıt sayfasına girdiğim kayıtları yine kayıt sayfasında bulunan buton aracılığı o güne ait, sarı renk ile belirttiğim bilgi alanıyla, şablon sayfasındaki ilgili bölüme aktarmayı bir türlü başaramadım.

Yardımcı olabilirseniz çok sevinirim.

Not: Şablon sayfasındaki veriler, günü 11.03.2012 olarak varsaydığımzda gelmesini istediğim verilerdir.
 

Ekli dosyalar

dangerousyaso' Alıntı:
Merhaba,

Bir konuda takıldım ve yardımınıza ihtiyacım var. Ekteki dosyadan da anlaşılacağı gibi, kayıt sayfasına girdiğim kayıtları yine kayıt sayfasında bulunan buton aracılığı o güne ait, sarı renk ile belirttiğim bilgi alanıyla, şablon sayfasındaki ilgili bölüme aktarmayı bir türlü başaramadım.

Yardımcı olabilirseniz çok sevinirim.

Not: Şablon sayfasındaki veriler, günü 11.03.2012 olarak varsaydığımzda gelmesini istediğim verilerdir.
Genişletmek için tıkla ...

Merhaba
Ben bugünü baz aldım ( Date ile )
Sayfanın kod bölümüne kopyalayın ve deneyin.
Kod: 
Option Explicit
Private Sub CommandButton1_Click()
'Konu       :   Bugünun Verilerini Aktar
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Worksheet
Dim a As Long, b As Long
Set asi = Sheets("Kayıt"): Set kral = Sheets("Şablon")
Application.ScreenUpdating = False
kral.Range("B3:E" & Rows.Count).ClearContents
a = asi.Range("B" & Rows.Count).End(xlUp).Row
asi.Range("B2:G" & a).AutoFilter field:=6, Criteria1:=">=" & CDbl(Date), _
Operator:=xlAnd, Criteria2:="<=" & CDbl(Date)
If WorksheetFunction.Subtotal(3, asi.Range("B3:B" & a)) > 0 Then
asi.Range("B3:E" & a).Copy Destination:=kral.Range("B3")
kral.Range("B3:E" & Rows.Count).Interior.Color = xlNone
End If
asi.Range("B2:G" & a).AutoFilter
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, "asi_kral_1967"
End Sub
Dosyanız Ekte.
 

Ekli dosyalar

Harikasınız. Çok teşekkürler. Peki şablona aktarılan verilen başına bir sütun daha eklesek ve onlara sıra numarası verelim desek, nasıl bir yol izlemeliyiz @asi_kral_1967.
 
dangerousyaso' Alıntı:
Harikasınız. Çok teşekkürler. Peki şablona aktarılan verilen başına bir sütun daha eklesek ve onlara sıra numarası verelim desek, nasıl bir yol izlemeliyiz @asi_kral_1967.
Genişletmek için tıkla ...

Merhaba
A sütununa sıra numarası yazar
Kod: 
Option Explicit
Private Sub CommandButton1_Click()
'Konu       :   Bugünun Verilerini Aktar
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Worksheet
Dim a As Long, b As Long
Set asi = Sheets("Kayıt"): Set kral = Sheets("Şablon")
Application.ScreenUpdating = False
kral.Range("A3:E" & Rows.Count).ClearContents
a = asi.Range("B" & Rows.Count).End(xlUp).Row
asi.Range("B2:G" & a).AutoFilter field:=6, Criteria1:=">=" & CDbl(Date), _
Operator:=xlAnd, Criteria2:="<=" & CDbl(Date)
If WorksheetFunction.Subtotal(3, asi.Range("B3:B" & a)) > 0 Then
asi.Range("B3:E" & a).Copy Destination:=kral.Range("B3")
kral.Range("B3:E" & Rows.Count).Interior.Color = xlNone
kral.Range("A3") = 1
kral.Range("A3:A" & kral.Range("B" & Rows.Count).End(xlUp).Row).DataSeries _
Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
End If
asi.Range("B2:G" & a).AutoFilter
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, "asi_kral_1967"
End Sub
Dosyanız ekte.
 

Ekli dosyalar

Harika. Bu da tam istediğim gibi oldu. Çok teşekkürler. Çok güzel bir çalışma yaptım sayenizde.
 
asi_kral_1967' Alıntı:
Kolay Gelsin.
Genişletmek için tıkla ...

Teşekkürler. Bir şey daha sorabilir miyim?

Kod: 
asi.Range("B2:G" & a).AutoFilter field:=6, Criteria1:=">=" & CDbl(Date), _
Operator:=xlAnd, Criteria2:="<=" & CDbl(Date)

Yukarıdaki bölümü ben

Kod: 
asi.Range("B2:G" & a).AutoFilter field:=6, Criteria1:=">=" & CDbl(Date)[COLOR="Red"] + 3[/COLOR], _
Operator:=xlAnd, Criteria2:="<=" & CDbl(Date)[COLOR="Red"] + 3[/COLOR]

olarak değiştirdim. Çünkü 3 gün sonrasına ait kayıtları da ayrı bir butonla şablona aktarmam gerekiyor. 3 gün sonra olan bir satır varsa o kaydı şablona aktarıyor ama örneğin bugün ayın 10 diyelim. Listemizde ayın 13'üne ait kayıt yoksa listedeki tüm kayıtları şablona aktarıyor. Ne tarz bir değişiklik yapılması gerekiyor acaba bu sorunu çözmek için?

Edit: Sanırım çözdüm. Aşağıdaki değişiklik işime yaradı. Yaptığım işlem doğru mudur?

Kod: 
If WorksheetFunction.Subtotal([COLOR="Red"]2[/COLOR], asi.Range("B3:B" & a)) > 0 Then
 
Son düzenleme:
Yukarıda yaptığım çözüm doğruysa bir şey daha aklıma geldi. Örneğin çıkış tarihleri mart ayında değil de nisan ya da mayıs ayında olanlar da var. Ben bunları bu ayki çıkışları ver dediğimde bana bunu sunabilir mi? Yani Mart'ın 1'inden mart'ın sonuna kadar olan tüm kayıtları listelesin.Mesela bunun için de yeni bir sayfa açarak verileri oraya rapor halinde kopyalatabilir miyiz? Bir de buna ek olarak, bugünden ay sonuna kadar olan kayıtları kopyalatabilir miyiz ayrı bir buton ile?

Epey vaktinizi aldım @asi_kral_1967, hakkınızı helal edin.
 
Son düzenleme:
Yaptığınız değişiklik yanlış
8. Nolu mesajı bu yüzden okumadım. Ne gibi bir işlem yapacaksanız dosyanızı ona göre güncelleyin bakayım.
 
asi_kral_1967' Alıntı:
Yaptığınız değişiklik yanlış
8. Nolu mesajı bu yüzden okumadım. Ne gibi bir işlem yapacaksanız dosyanızı ona göre güncelleyin bakayım.
Genişletmek için tıkla ...

Dosya ektedir. 3 Gün sonraki çıkışları aktar butonuna bastığımda bugünün tarihinden 3 gün ilerideki çıkış tarihli satırları başlona aktarmasını istiyorum. Çok teşekkürler şimdiden.
 

Ekli dosyalar

dangerousyaso' Alıntı:
Yukarıda yaptığım çözüm doğruysa bir şey daha aklıma geldi. Örneğin çıkış tarihleri mart ayında değil de nisan ya da mayıs ayında olanlar da var. Ben bunları bu ayki çıkışları ver dediğimde bana bunu sunabilir mi? Yani Mart'ın 1'inden mart'ın sonuna kadar olan tüm kayıtları listelesin.Mesela bunun için de yeni bir sayfa açarak verileri oraya rapor halinde kopyalatabilir miyiz? Bir de buna ek olarak, bugünden ay sonuna kadar olan kayıtları kopyalatabilir miyiz ayrı bir buton ile?

Epey vaktinizi aldım @asi_kral_1967, hakkınızı helal edin.
Genişletmek için tıkla ...

Yapmak istediğim değişiklikleri eklediğim ekte anlatmaya çalıştım. Umarım açıklayıcı olmuşumdur. Tekrar tekrar teşekkürler.
 

Ekli dosyalar

dangerousyaso' Alıntı:
Dosya ektedir. 3 Gün sonraki çıkışları aktar butonuna bastığımda bugünün tarihinden 3 gün ilerideki çıkış tarihli satırları başlona aktarmasını istiyorum. Çok teşekkürler şimdiden.
Genişletmek için tıkla ...

Merhaba
Kodu bu şekilde değiştirdim bir problem olmadı 3. gün sonrasının verilerini aktardı
Kod: 
Private Sub CommandButton2_Click()
'Konu       :   3. Gün Sonrasının  Verilerini Aktar
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Worksheet
Dim a As Long, b As Long
Set asi = Sheets("Kayıt"): Set kral = Sheets("Şablon")
Application.ScreenUpdating = False
kral.Range("A3:E" & Rows.Count).ClearContents
a = asi.Range("B" & Rows.Count).End(xlUp).Row
asi.Range("B2:G" & a).AutoFilter field:=6, Criteria1:=">=" & CDbl(Date + 3), _
Operator:=xlAnd, Criteria2:="<=" & CDbl(Date + 3)
If WorksheetFunction.Subtotal(3, asi.Range("B3:B" & a)) > 0 Then
asi.Range("B3:E" & a).Copy Destination:=kral.Range("B3")
kral.Range("B3:E" & Rows.Count).Interior.Color = xlNone
kral.Range("A3") = 1
kral.Range("A3:A" & kral.Range("B" & Rows.Count).End(xlUp).Row).DataSeries _
Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
End If
asi.Range("B2:G" & a).AutoFilter
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, "asi_kral_1967"
End Sub
Dosyanız ekte.
 

Ekli dosyalar

asi_kral_1967' Alıntı:
Doğru gözümden kaçtı çünkü 2. mesajda bir soru değiştiriyorsunuz.
Bu butonda ne olacak anlamadım.
Genişletmek için tıkla ...

kusura bakmayın, ne sorduysam yardımcı oldunuz. Biraz fazla kacırdım sanırım soruları. Özur dilerım.

O belırttıgınız butonda, cıkıs tarıhı bugunden once olan satırlar degılde, yarından ıtıbaren ve ay sonuna kadar olan cıkıs tarıhlı tüm kayıtları aktarsın ıstemıstım
 
dangerousyaso' Alıntı:
kusura bakmayın, ne sorduysam yardımcı oldunuz. Biraz fazla kacırdım sanırım soruları. Özur dilerım.

O belırttıgınız butonda, cıkıs tarıhı bugunden once olan satırlar degılde, yarından ıtıbaren ve ay sonuna kadar olan cıkıs tarıhlı tüm kayıtları aktarsın ıstemıstım
Genişletmek için tıkla ...

Merhaba
Sayfanın Kod bölümündeki kodları silin ve bunları yapıştırın.
Kod: 
Option Explicit
Private Sub CommandButton1_Click()
'Konu       :   Bugünun Verilerini Aktar
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Worksheet
Dim a As Long, b As Long
Set asi = Sheets("Kayıt"): Set kral = Sheets("Şablon")
Application.ScreenUpdating = False
kral.Range("A3:E" & Rows.Count).ClearContents
a = asi.Range("B" & Rows.Count).End(xlUp).Row
asi.Range("B2:G" & a).AutoFilter field:=6, Criteria1:=">=" & CDbl(Date), _
Operator:=xlAnd, Criteria2:="<=" & CDbl(Date)
If WorksheetFunction.Subtotal(3, asi.Range("B3:B" & a)) > 0 Then
asi.Range("B3:E" & a).Copy Destination:=kral.Range("B3")
kral.Range("B3:E" & Rows.Count).Interior.Color = xlNone
kral.Range("A3") = 1
kral.Range("A3:A" & kral.Range("B" & Rows.Count).End(xlUp).Row).DataSeries _
Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
End If
asi.Range("B2:G" & a).AutoFilter
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, "asi_kral_1967"
End Sub
Private Sub CommandButton2_Click()
'Konu       :   3. Gün Sonrasının  Verilerini Aktar
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Worksheet
Dim a As Long, b As Long
Set asi = Sheets("Kayıt"): Set kral = Sheets("Şablon")
Application.ScreenUpdating = False
kral.Range("A3:E" & Rows.Count).ClearContents
a = asi.Range("B" & Rows.Count).End(xlUp).Row
asi.Range("B2:G" & a).AutoFilter field:=6, Criteria1:=">=" & CDbl(Date + 3), _
Operator:=xlAnd, Criteria2:="<=" & CDbl(Date + 3)
If WorksheetFunction.Subtotal(3, asi.Range("B3:B" & a)) > 0 Then
asi.Range("B3:E" & a).Copy Destination:=kral.Range("B3")
kral.Range("B3:E" & Rows.Count).Interior.Color = xlNone
kral.Range("A3") = 1
kral.Range("A3:A" & kral.Range("B" & Rows.Count).End(xlUp).Row).DataSeries _
Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
End If
asi.Range("B2:G" & a).AutoFilter
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, "asi_kral_1967"
End Sub
Private Sub CommandButton3_Click()
'Konu       :   Bulunduğun Ayın Verilerini Aktar
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Worksheet
Dim a As Long, b As Long
Set asi = Sheets("Kayıt"): Set kral = Sheets("Bu Ay")
Application.ScreenUpdating = False
kral.Range("A3:E" & Rows.Count).ClearContents
a = asi.Range("B" & Rows.Count).End(xlUp).Row
asi.Range("B2:G" & a).AutoFilter field:=6, Criteria1:=">=" & CDbl(DateSerial(Year(Date), _
Month(Date), 1)), Operator:=xlAnd, Criteria2:="<=" & CDbl(DateSerial(Year(Date), _
Month(Date) + 1, 0))
If WorksheetFunction.Subtotal(3, asi.Range("B3:B" & a)) > 0 Then
asi.Range("B3:E" & a).Copy Destination:=kral.Range("B3")
kral.Range("B3:E" & Rows.Count).Interior.Color = xlNone
kral.Range("A3") = 1
kral.Range("A3:A" & kral.Range("B" & Rows.Count).End(xlUp).Row).DataSeries _
Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
End If
asi.Range("B2:G" & a).AutoFilter
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, "asi_kral_1967"
End Sub
Private Sub CommandButton4_Click()
'Konu       :   Bulunduğun Ayın Başından ve Yarına Verilerini Aktar
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Worksheet
Dim a As Long, b As Long
Set asi = Sheets("Kayıt"): Set kral = Sheets("Kalan Çıkışlar")
Application.ScreenUpdating = False
kral.Range("A3:E" & Rows.Count).ClearContents
a = asi.Range("B" & Rows.Count).End(xlUp).Row
asi.Range("B2:G" & a).AutoFilter field:=6, Criteria1:=">=" & CDbl(Date + 1), _
Operator:=xlAnd, Criteria2:="<=" & CDbl(DateSerial(Year(Date), Month(Date) + 1, 0))
If WorksheetFunction.Subtotal(3, asi.Range("B3:B" & a)) > 0 Then
asi.Range("B3:E" & a).Copy Destination:=kral.Range("B3")
kral.Range("B3:E" & Rows.Count).Interior.Color = xlNone
kral.Range("A3") = 1
kral.Range("A3:A" & kral.Range("B" & Rows.Count).End(xlUp).Row).DataSeries _
Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
End If
asi.Range("B2:G" & a).AutoFilter
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, "asi_kral_1967"
End Sub
Dosyanız Ekte
 

Ekli dosyalar

Yardımlarınız için çok ama çok teşekkür ederim. Sayenizde günde yaklaşık 1 saat harcamaktan kurtuldum. İşlerimi artık 1 dakikadan da kısa bir sürede yapabileceğim. Hakkınızı helal edin.
 
dangerousyaso' Alıntı:
Yardımlarınız için çok ama çok teşekkür ederim. Sayenizde günde yaklaşık 1 saat harcamaktan kurtuldum. İşlerimi artık 1 dakikadan da kısa bir sürede yapabileceğim. Hakkınızı helal edin.
Genişletmek için tıkla ...

Kolay Gelsin.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst