makro ile otomatik süz ve yapıştır

[ozlemaltin]

SATIR1= VADE TARİH TOPLAM
SATIR2=5 22.11.2011 5.000,00
SATIR3=5 20.11.2011 2.000,00
SATIR4=2 13.11.2011 8.000,00
SATIR5=2 08.11.2011 6.000,00




SütunA1 de yazan 5e göre otomatik yeni sayfalar açarak ilgili listeden 5'i otomatik süzüp tarih ve toplam sütunlarını da yapıştırsın istiyorum.



Bu anlatmak için yaptığım basit bir örnek ilgili çalışmam 1-1000 aralığında ve çok uzun bir data basit örnek üzerinden makro yazarak yardım rica ederim. Ben onu şekillendirebilirim. Sayfa açma otomatik süz ve şartlı işlemleri bir arada yapamadım
Teşekkürler,


hızlı dönüşünüz için teşekkür ederim, ilgili çalışma ekte.

 

[İhsan Tank]

Merhaba
Anladığım kadarı ile A sütununda yazan'a göre Yeni sayfa oluşturup bu sayfalara veri aktarmak istiyorsunuz_?
Dosya eklerseniz onun üzerinden çözüm üretelim.

 

[ozlemaltin]

çalışmayı ekledim, blg
Teşekkürler,

 

[İhsan Tank]

çalışmayı ekledim, blg
Teşekkürler,

Merhaba
Boş bir module kopyalayın ve deneyin.

Option Explicit
Sub sayfalara_ayır_aktar_61()
Dim ts, kaplan, trabzonspor, asi, hamsi As Date
Dim bordo, mavi
Set bordo = Sheets("list")
trabzonspor = MsgBox("Sayfalara Ayırıp Aktarım Yapıyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
hamsi = Time
For ts = Sheets.Count To 2 Step -1
Application.DisplayAlerts = False
Sheets(ts).Delete
Application.DisplayAlerts = True
Next
For ts = 2 To bordo.Cells(Rows.Count, "A").End(xlUp).Row
If WorksheetFunction.CountIf(bordo.Range("A2:A" & ts), _
bordo.Cells(ts, "A")) = 1 Then
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = bordo.Cells(ts, "A")
bordo.Rows(1).Copy Destination:=Sheets(Sheets.Count).Range("A1")
End If
Next
For ts = 2 To Sheets.Count
Sheets(ts).Select
Set mavi = Sheets(ts)
kaplan = 2
Set asi = bordo.Range("A:A").Find(Sheets(ts).Name, , , xlWhole)
If Not asi Is Nothing Then
trabzonspor = asi.Address
Do
mavi.Cells(kaplan, "A") = bordo.Cells(asi.Row, "A")
mavi.Cells(kaplan, "B") = bordo.Cells(asi.Row, "B")
mavi.Cells(kaplan, "C") = bordo.Cells(asi.Row, "C")
kaplan = kaplan + 1
Set asi = bordo.Range("A:A").FindNext(asi)
Loop While Not asi Is Nothing And asi.Address <> trabzonspor
End If
Next
Application.ScreenUpdating = True
MsgBox Format(hamsi - Time, "hh:mm:ss") & " Sürede" & vbLf _
& "Sayfalara Ayırıp Aktarım Yaptım", , "Bitiş"
End Sub

 

[ozlemaltin]

merhaba,

emeğiniz için teşekkür ederim. Detayda da belirttiğim gibi yeni sayfaya açarak yapması gerekiyor işlemi... yeni sayfa açma ve sayfalara yönlendirme konusunda sıkıntı yaşıyorum.Otomatik süzüp A sütununda yazan değerler kadar sayfa açsın ve karşılığını kopyalasın istiyorum. Çok şey istedim ama detaydaki komut eski paylaşımlarınızda da vardı.
Tşekler.

 

[İhsan Tank]

merhaba,

emeğiniz için teşekkür ederim. Detayda da belirttiğim gibi yeni sayfaya açarak yapması gerekiyor işlemi... yeni sayfa açma ve sayfalara yönlendirme konusunda sıkıntı yaşıyorum.Otomatik süzüp A sütununda yazan değerler kadar sayfa açsın ve karşılığını kopyalasın istiyorum. Çok şey istedim ama detaydaki komut eski paylaşımlarınızda da vardı.
Tşekler.

Üstteki kodu güncelledim.

 

[ozlemaltin]

çok teşekkür ederim, selamlar

 

[İhsan Tank]

çok teşekkür ederim, selamlar

Rica ederim
:keyif: