Diğer sayfaya süzerek liste aktarma

86126 · 19 Eylül 2011

Arkadaşlar iyi çalışmalar,
sayfa1 de bir listem var, ve bu listenin bir sutünuna göre sayfa2 de otomatik listeler yapmak istiyorum. office 2010 kullanıyorum. 2003 ve 2010 formatında örnek ekledim yardımlarınızı bekliyorum. şimdiden teşekkürler

Necdet · 19 Eylül 2011

Merhaba,

Sayfa1 de Süz işlemini yaptıktan sonra aşağıdaki kodları kullanabilirsiniz.

Kod:

Sub Aktar()
 
    Dim i   As Long, _
        s1  As Worksheet, _
        s2  As Worksheet
    
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    s1.Select
    If ActiveSheet.AutoFilterMode = False Then
        MsgBox "Süzülmüş Veri Bulamadım......", vbCritical, "N. YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
        Exit Sub
    End If
    i = s2.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 2
    
    s1.Range("A1").CurrentRegion.Copy s2.Cells(i, "A")
    MsgBox "Aktardım.....", vbInformation, "N. YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    
End Sub

86126 · 19 Eylül 2011

s1.Range("A1").CurrentRegion.Copy s2.Cells(i, "A")

İlginiz için teşekkür ederim. Çalıştırdığımda burada hata gösterdi.

Necdet · 19 Eylül 2011

86126' Alıntı:
s1.Range("A1").CurrentRegion.Copy s2.Cells(i, "A")

İlginiz için teşekkür ederim. Çalıştırdığımda burada hata gösterdi.

Hata çok açık değil mi? Açıklama olarak yazdığınız ve birleştirdiğiniz hücreye veriyor, Birleştirmeyi kaldırın ve yeniden deneyin.

assenucler · 19 Eylül 2011

Dosyayı indirdim ve izne çıkan kişiyi "Filtre" ile süzdüm ve "Süzülen Verileri Sayfa2'ye Aktar" düğmeye tıklayınca "İşlem Tamamlandı" iletisi çıktı.

Hata iletisi almadım.

Sayın Necdet Yeşertener hocam, katkınız için teşekkürler.

Sevgi ve saygılar..

86126 · 19 Eylül 2011

Teşekkür ederim Hocam. Yalnız ben bu işlemi süzme yapmadan otomatik yapmasını istiyorum. Bunu nasıl yapabiliriz.

Necdet · 19 Eylül 2011

86126' Alıntı:
Teşekkür ederim Hocam. Yalnız ben bu işlemi süzme yapmadan otomatik yapmasını istiyorum. Bunu nasıl yapabiliriz.

Otomatikten kastınız?

86126 · 19 Eylül 2011

Sayfa1 veri girdiğimde Sayfa1 deki F sütunundaki verilere göre bana sayfa ikide listeler oluştursun.

Necdet · 19 Eylül 2011

86126' Alıntı:
Sayfa1 veri girdiğimde Sayfa1 deki F sütunundaki verilere göre bana sayfa ikide listeler oluştursun.

Bir aktarılan bir daha aktarılırsa ne olacak, yani mükerrer veriler için bir düşünceniz var mı?

Soruyu ya tam anlamadım ya da pek mantıklı bulmadım.

86126 · 19 Eylül 2011

Deneme olarak gönderdiğim dosyaya bakabilirseniz. Sayfa2 de nasıl geçmesi gerektiğini gösterdim. İlginiz için teşekkür ederim. İnşallah anlata bilmişimdir. Sayfa1 deki F sütununun verilerine göre ayrı bir liste istiyorum.

Necdet · 19 Eylül 2011

Merhaba,

Canınız ne zaman aktarmak isterse aşağıdaki kodları kullanabilirsiniz.

Kod:

Sub Aktar()
 
    Dim i       As Integer, _
        Sat     As Long, _
        SSat    As Long, _
        SKol    As Integer, _
        Secim   As Range, _
        Liste() As String, _
        s1      As Worksheet, _
        s2      As Worksheet
        
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    s1.Select
    
    On Error Resume Next
    
    Application.ScreenUpdating = False
    'Önceki Verilerin Silinmesi Gerekiyorsa 2 Satır Durmalı
    SSat = s2.Cells(Rows.Count, "A").End(3).Row + 5
    s2.Range("A2:I" & SSat).ClearContents
    'Önceki Verileri Silme Sonu
    
    SKol = Cells.Find("*", , , , xlByColumns, xlPrevious).Column + 1
    
    Range("F:F").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, SKol), Unique:=True
    SSat = Cells(Rows.Count, SKol).End(3).Row
    
    ReDim Liste(SSat - 2)
    
    For i = 2 To SSat
        Liste(i - 2) = Cells(i, SKol)
    Next i
    
    Columns(SKol).Clear
    SSat = Cells(Rows.Count, "A").End(3).Row
    
    Selection.AutoFilter
    
    For i = 0 To UBound(Liste)
    
        ActiveSheet.Range("A1:J" & SSat).AutoFilter Field:=6, Criteria1:=Liste(i)
        ActiveSheet.Range("A1:J" & SSat).AutoFilter Field:=7, Criteria1:="<>"
    
        If Cells(Rows.Count, "A").End(3).Row > 1 Then
            Sat = s2.Cells(Rows.Count, "A").End(3).Row + 2
            Range("A1").CurrentRegion.Copy s2.Cells(Sat, "A")
        End If
        
    Next i
    
    ActiveSheet.ShowAllData
    
    Application.ScreenUpdating = False
    MsgBox "AKTARIM TAMAMLANMIŞTIR....", vbInformation, "N. YEŞERTENER...."
    
End Sub

86126 · 19 Eylül 2011

Çok teşekkür ederim. Tam istediğim gibi. Ancak G VE H hücrelerne veri girilmemişse hesaplama yapmasın dan kastım I hücresindeki formüldü. Buna göre tekrar bakabilirseniz çok sevinirim.

Necdet · 19 Eylül 2011

Yani KİŞİizne çıkmadıysa dönüş tarihi boş görünsün mü diyorsunuz?

Bunu istiyorsanız I2

Kod:

=EĞER(BAĞ_DEĞ_DOLU_SAY(G2:H2)=2;H2+G2;"")

86126 · 19 Eylül 2011

Çok teşekkür ederim. Evet doğru. Makroyu değiştirebilirmiyiz. Sadece F hücresindeki verilere göre süzecek. Başka kriter olmayacak. İlginize tekrar teşekkür ederim.

Necdet · 19 Eylül 2011

Merhaba,

Field:=7

Geçen satırı silerseniz sadece 6. alan yani F ye göre süzer.

86126 · 19 Eylül 2011

Çok teşekkür ederim beyninize sağlık.

86126 · 29 Eylül 2011

Aktardığımız verilere yeni sıra numarası verdirebilirmiyiz. Her gruba yeni numara versin.

Necdet · 29 Eylül 2011

Merhaba,

Kodlarda değişiklik yaptım.

Kod:

Sub Aktar()
 
    Dim i       As Long, _
        j       As Long, _
        Sat     As Long, _
        SSat    As Long, _
        SKol    As Integer, _
        Secim   As Range, _
[B][COLOR=red]        c       As Range, _
        Adr     As String, _
[/COLOR][/B]        Liste() As String, _
        s1      As Worksheet, _
        s2      As Worksheet
        
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    s1.Select
    
    On Error Resume Next
    
    Application.ScreenUpdating = False
    'Önceki Verilerin Silinmesi Gerekiyorsa 2 Satır Durmalı
    SSat = s2.Cells(Rows.Count, "A").End(3).Row + 5
    s2.Range("A2:I" & SSat).ClearContents
    'Önceki Verileri Silme Sonu
    
    SKol = Cells.Find("*", , , , xlByColumns, xlPrevious).Column + 1
    
    Range("F:F").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, SKol), Unique:=True
    SSat = Cells(Rows.Count, SKol).End(3).Row
    
    ReDim Liste(SSat - 2)
    
    For i = 2 To SSat
        Liste(i - 2) = Cells(i, SKol)
    Next i
    
    Columns(SKol).Clear
    SSat = Cells(Rows.Count, "A").End(3).Row
    
    Selection.AutoFilter
    
    For i = 0 To UBound(Liste)
    
        ActiveSheet.Range("A1:J" & SSat).AutoFilter Field:=6, Criteria1:=Liste(i)
        [COLOR=red][B]ActiveSheet.Range("A1:J" & SSat).AutoFilter Field:=9, Criteria1:="<>"
[/B][/COLOR]    
        If Cells(Rows.Count, "A").End(3).Row > 1 Then
            Sat = s2.Cells(Rows.Count, "A").End(3).Row + 2
            Range("A1").CurrentRegion.Copy s2.Cells(Sat, "A")
        End If
        
    Next i
    
    
[B][COLOR=red]    'Sayfa2 de yeniden numara verilir
    With s2.Range("a:a")
        Set c = .Find("NO", LookIn:=xlValues)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                i = c.Row + 1
                j = 0
                Do Until s2.Cells(i, "B") = ""
                    j = j + 1
                    s2.Cells(i, "A") = j
                    i = i + 1
                Loop
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
[/COLOR][/B]    
    
    ActiveSheet.ShowAllData
    
    Application.ScreenUpdating = False
    MsgBox "AKTARIM TAMAMLANMIŞTIR....", vbInformation, "N. YEŞERTENER...."
    
End Sub

86126 · 29 Eylül 2011

Çok teşekkür ederim. Beyninize sağlık.

Necdet · 29 Eylül 2011

Tekrar merhaba,

Döngü içinde döngü olmaması için Seri ile doldurma yöntemini kullandım bu sefer.

Kod:

Sub Aktar()
 
    Dim i       As Long, _
        j       As Long, _
        Sat     As Long, _
[COLOR=red]        Sat1    As Long, _
[/COLOR]        SSat    As Long, _
        SKol    As Integer, _
        Secim   As Range, _
        Liste() As String, _
        s1      As Worksheet, _
        s2      As Worksheet
        
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    s1.Select
    
    On Error Resume Next
    
    Application.ScreenUpdating = False
    'Önceki Verilerin Silinmesi Gerekiyorsa 2 Satır Durmalı
    SSat = s2.Cells(Rows.Count, "A").End(3).Row + 5
    s2.Range("A2:I" & SSat).ClearContents
    'Önceki Verileri Silme Sonu
    
    SKol = Cells.Find("*", , , , xlByColumns, xlPrevious).Column + 1
    
    Range("F:F").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, SKol), Unique:=True
    SSat = Cells(Rows.Count, SKol).End(3).Row
    
    ReDim Liste(SSat - 2)
    
    For i = 2 To SSat
        Liste(i - 2) = Cells(i, SKol)
    Next i
    
    Columns(SKol).Clear
    SSat = Cells(Rows.Count, "A").End(3).Row
    
    Selection.AutoFilter
    
    For i = 0 To UBound(Liste)
    
        ActiveSheet.Range("A1:J" & SSat).AutoFilter Field:=6, Criteria1:=Liste(i)
        ActiveSheet.Range("A1:J" & SSat).AutoFilter Field:=9, Criteria1:="<>"
    
        If Cells(Rows.Count, "A").End(3).Row > 1 Then
            Sat = s2.Cells(Rows.Count, "A").End(3).Row + 2
            Range("A1").CurrentRegion.Copy s2.Cells(Sat, "A")
[COLOR=red]            Sat1 = s2.Cells(Rows.Count, "A").End(3).Row
            Sat = Sat + 1
            s2.Range("A" & Sat) = 1
            s2.Range("A" & Sat & ":A" & Sat1).DataSeries
[/COLOR]        End If
        
    Next i
      
    ActiveSheet.ShowAllData
    
    Application.ScreenUpdating = False
    MsgBox "AKTARIM TAMAMLANMIŞTIR....", vbInformation, "N. YEŞERTENER...."
    
End Sub

Diğer sayfaya süzerek liste aktarma

86126

Ekli dosyalar

Necdet

Moderatör

Ekli dosyalar

86126

Necdet

Moderatör

assenucler

86126

Necdet

Moderatör

86126

Necdet

Moderatör

86126

Necdet

Moderatör

Ekli dosyalar

86126

Necdet

Moderatör

86126

Necdet

Moderatör

86126

86126

Necdet

Moderatör

Ekli dosyalar

86126

Necdet

Moderatör

Ekli dosyalar