Sütundaki değerleri sayfalara ayırma

[eftel]

Herkese Merhaba. Foruma yeni üye oldum üye olmadan öncede bolca buradaki bilgilerden faydalandım izninzile işime çok lazım olacak bir soru sormak istiyorum daha öncede araştırma yaptım fakat uygun bir çözüm bulamadım. Ekteki örnekte herbir sayfaya tescil numaralarını ayırarak mesela tescil numarası 250 olanlar sayfa "TESCİL NUMARASI 250 OLANLAR" sayfasına kopyalanacak şekilde nasıl formül yazabilirim. Yardımcı olursanız çok minnettar kalacağım günümümün büyük bir bölümünü sırf bunun için harcıyorum.

 

[muygun]

Merhaba;
Yerinde bir karar. Üyeliğiniz hayırlı olsun.
Eki inceleyin. (kodlar alıntıdır)
İyi çalışmalar.

 

[eftel]

Çok çok teşekkür ederim işime çok yarayacak, son bir kez birşey daha danışacam size gerçi dosyanın içinde belirmişsiniz ama sayfalara dağıt dedikten sonra yanlarda birleştirilmiş ismler vb cıkıyor bunları nasıl kolayca silebilirim yada yok edebilirim. İlginize tekrar teşekkür ederim.

 

[Necdet]

Merhaba,

Kendim için yaptığım bir çalışmayı buraya ekleyim.

Önce aşağıdaki dosyayı açınız, sonra kendi dosyanızı açınız. Kendi Dosyanız aktif iken aşağıdaki dosyadaki "DosyalaraAktar" makrosunu çalıştırınız. Fırsatını bulduğumda Menü içine eklemeyi yaparım.

Dosya veya sayfalara ayıracağınz sütunu seçerek devam ediniz. Seçtiğiniz sütundaki verilere göre sayfa açar ya da o adla dosya oluşturur.

Dosyalar aktif olan dosya yolunda oluşur. Güle güle kullanınız. Satır ve Sütun sınırı yoktur.

Sub DosyalaraAktar()
 
    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, _
        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")
 
    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
            Application.Wait (Now + TimeValue("0:00:02"))
        End If
    Next i
 
    ActiveSheet.ShowAllData
 
    Application.ScreenUpdating = False
    MsgBox "DOSYALARA AKTARIM TAMAMLANMIŞTIR....", vbInformation, "N. YEŞERTENER...."
 
End Sub

 

[eftel]

Necdet Bey elnize sağlık cok teşekkür ediyorum. Bir şey daha rica etsem fazlamı olurum acaba shettlere isim nasıl verebilirim. örneğin tescil nolarına göre ayırdı artık bunda sıkıntı yok ama sheetlerede "MUN NO-2 250" (buradaki 250 örnek dosyadaki tescil no MUH NO ise muhasebe numarası 1...2..3 gibi) ismi nasıl verebilir. Tekrar teşekkür ederim.

 

[Necdet]

Necdet Bey elnize sağlık cok teşekkür ediyorum. Bir şey daha rica etsem fazlamı olurum acaba shettlere isim nasıl verebilirim. örneğin tescil nolarına göre ayırdı artık bunda sıkıntı yok ama sheetlerede "MUN NO-2 250" (buradaki 250 örnek dosyadaki tescil no MUH NO ise muhasebe numarası 1...2..3 gibi) ismi nasıl verebilir. Tekrar teşekkür ederim.

Merhaba,

MUH, MUN derken kafam karıştı. Sorunuzu pek anlamadım ama sayfa başlarına illaki MUH gibi bir bilgi gelecekse sayfa oluştururken MUH sözcüğünü de eklemek gerekir.

Ama benim size önerdiğim yukarıdaki kodlar genel amaçlı kodlar. Bu sorunuzda MUH isterseniz başka bir dosyada başka bir ön ek isteyebilirsiniz.

Bence bu şekilde genel amaçlı olarak kalsın derim.

 

[musgir]

Necdet Bey,
Elinize sağlık, çok pratik ve kolay bir uygulama olmuş. Bir sorum olacak.
Kod ile ana dosyamızı dosyalara aktardığımızda, yeni oluşan dosyalardaki sütun genişliklerinin, ana dosyamızdaki sütun genişlikleri ile aynı olması ve bütün hücrelerde "metni kaydır" özelliğinin deaktif olmasını nasıl sağlayabiliriz ?

 

[musgir]

Necdet Bey,
Elinize sağlık, çok pratik ve kolay bir uygulama olmuş. Bir sorum olacak.
Kod ile ana dosyamızı dosyalara aktardığımızda, yeni oluşan dosyalardaki sütun genişliklerinin, ana dosyamızdaki sütun genişlikleri ile aynı olması ve bütün hücrelerde "metni kaydır" özelliğinin deaktif olmasını nasıl sağlayabiliriz ?

Sorunun çözüme ulaşmaması nedeniyle, günceldir.