Soru Benzer verilere göre yeni çalışma sayfasına kopyalama

[iztepne]

Merhaba;
Excel Veriler çalışma sayfasındaki tabloda F sütunda ki benzer verilere göre değerlerini yeni bir çalışma sayfasına kopyalanması ve çalışma sayfasına verinin adının verilmesi konusunda yardımcı olur musunuz?

Örneğin F sütununda Eğitim durumları var ise veriler listesinde Eğitim durumu Üniversite yaz kişileri bulup üniversite adında yeni bir çalışma sayfası oluşturup üniversite mezunu kişileri kopyalatmak istiyorum.

Teşekkür ederim.

 

[Necdet]

Merhaba,

Paylaşım sitelerin birine basit örnek bir dosya eklerseniz, kodları yazacak olan arkadaşa yardımcı olmuş olursunuz. Satır sayısı önemli değil ama sütun sayısı önemli olabilmekte.

 

[iztepne]

Bilgilendirme için teşekkür ederm. Örnek paylaşım :

20220106080116.xls

docs.google.com

 

[Necdet]

Merhaba,

Yıllar önce kendim için yazdığım kodları buraya ekliyorum.
Kodlar ilgili sayfadaki bilgileri sizin belirlediğiniz kolondaki benzersiz verileri dikkate alarak ister ayrı dosyalara isterse sayfalara aktarır.

Kodları bir modüle kopyalayıp deneyiniz.

Sub Dosyalara_Sayfalara_Ayır()

'Necdet www.excel.web.tr

    Dim i           As Long, _
        SSat        As Long, _
        Sat         As Long, _
        SKol        As Integer, _
        BKol        As Integer, _
        DosyaSayfa  As Integer, _
        Secim       As Range, _
        rngAlan     As Range, _
        Liste()     As String, _
        Yol         As String, _
        DosyaAd     As String, _
        DosyaUz     As String, _
        DosyaSy     As String, _
        Surum       As String, _
        Mes         As String, _
        ws          As Worksheet, _
        wsNew       As Worksheet
        
    Surum = ActiveWorkbook.FileFormat
    Set ws = Sheets(ActiveSheet.Name)
    
    On Error Resume Next
Basla:
    DosyaSayfa = Application.InputBox("1. SAYFALARA AYIRMA, 2. DOSYALARA AYIRMA, 3. YAZDIR", "YÖNTEM SEÇİMİ.....", 1, Type:=1)
    If DosyaSayfa = 0 Then Exit Sub
    If DosyaSayfa > 3 Then GoTo Basla
    
    Yol = ActiveWorkbook.Path & Application.PathSeparator
    DosyaUz = ".xlsx"
    If DosyaSayfa = 2 Then DosyaSy = InputBox("Dosya Adı Ne Olarak Başlasın", "Dosya Adı Girişi")
        
    On Error Resume Next
    Application.DisplayAlerts = False
    
    Set Secim = Application.InputBox("Sütunu seçmek için bir hücre(ler) Seçiniz", "N. YEŞERTENER --> Sütun Belirleme", Type:=8)
    If Secim Is Nothing Then Exit Sub
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    Sat = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    SKol = Cells.Find("*", , , , xlByColumns, xlPrevious).Column + 1
    BKol = Secim.Column
    
    Set rngAlan = Range(Cells(1, 1), Cells(Sat, SKol - 1))
    
    Columns(BKol).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
    SKol = SKol - 1
    
    Selection.AutoFilter
    
    If DosyaSayfa = 1 Then
        Sheets(Liste).Delete
        For i = 0 To UBound(Liste)
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Liste(i)
        Next i
        ws.Select
    End If
    
    For i = 0 To UBound(Liste)
        ActiveSheet.Range(Cells(1, 1), Cells(Sat, SKol - 1)).AutoFilter Field:=BKol, Criteria1:=Liste(i)
        Range("A1").CurrentRegion.Copy
    
        If DosyaSayfa = 1 Then
            Sheets(Liste(i)).Select
            ActiveSheet.Paste
            Cells.EntireColumn.AutoFit
            Range("A1").Select
            ws.Select
        ElseIf DosyaSayfa = 2 Then
            Workbooks.Add
            ActiveSheet.Paste
            Cells.EntireColumn.AutoFit
            Range("A1").Select
            Application.CutCopyMode = False
            ActiveWorkbook.SaveAs Filename:=Yol & DosyaSy & Liste(i), _
                 FileFormat:=Surum, CreateBackup:=False
            ActiveWorkbook.Close Savechanges:=False
        Else
            ActiveSheet.PrintOut
        End If
    Next i
    
    ActiveSheet.ShowAllData
    
    Application.ScreenUpdating = False

    If DosyaSayfa = 1 Then
        Mes = "SAYFALARA"
    Else
        Mes = "DOSYALARA"
    End If
    
    MsgBox Mes & " AKTARIM TAMAMLANMIŞTIR....", vbInformation, "N. YEŞERTENER...."
    
End Sub

 

[iztepne]

Çok teşekkür ederim. Tam istediğim gibi hatta fazlası.

 

[Necdet]

Çok teşekkür ederim. Tam istediğim gibi hatta fazlası.

Güle güle kullanın

 

[Necdet]

Necdet Bey merhaba,

Siz ne yapmışsınız böyle çok teşekkür ederim.

Sağlıklar diliyorum.

ihtiyaçlar, ne yaparsınız

 

[HücrelereFısıldayanAdam]

Harika bir kod bravo!