• DİKKAT

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

SAYFALARI BELİRLİ KISTASA GÖRE BÖLME

E

EMRE YALÇIN

Katılım
21 Haziran 2021
Mesajlar
64
Excel Vers. ve Dili
türkçe
Merhaba. Örnekteki sayfayı köylere göre bölüp yazdırmak istriyorum. Bunu yaparken ortada ki mavi çizgiyi manuel olarak sürekli aşağı yukarı yapmadan nasıl yapabilirim.
 

Ekli dosyalar

Merhaba,

Yıllar önce yazdığım aşağıdaki kodları bulamadım, bulsaydım linkini vermekle yetinecektim.

Aşağıdaki kodları bir modüle ekleyip yeni bir dosya oluşturur ve işlem göreceğiniz dosya aktif halde olursa kodlar her dosyada çalışacaktır.

Ya da doğrudan ilgili dosyanıza kopyalayıp çalıştırın.

Kod: 
Sub Dosya_Sayfalara_Aktar_Yazdir()
    
    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, _
        ileti       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
    
    If DosyaSayfa = 1 Then
        ileti = "SAYFALARA AYIRMA"
    ElseIf DosyaSayfa = 2 Then
        ileti = "DOSYALARA AYIRMA"
    Else
        ileti = "YAZDIRMA"
    End If
    
    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
            Application.Wait (Now + TimeValue("0:00:02"))
        End If
    Next i
    
    ActiveSheet.ShowAllData
    
    Application.ScreenUpdating = False

    MsgBox ileti & " İŞLEMİ TAMAMLANMIŞTIR....", vbInformation, "N. YEŞERTENER...."
    
End Sub
 
Necdet' Alıntı:
Merhaba,

Yıllar önce yazdığım aşağıdaki kodları bulamadım, bulsaydım linkini vermekle yetinecektim.

Aşağıdaki kodları bir modüle ekleyip yeni bir dosya oluşturur ve işlem göreceğiniz dosya aktif halde olursa kodlar her dosyada çalışacaktır.

Ya da doğrudan ilgili dosyanıza kopyalayıp çalıştırın.

Kod: 
Sub Dosya_Sayfalara_Aktar_Yazdir()
   
    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, _
        ileti       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
   
    If DosyaSayfa = 1 Then
        ileti = "SAYFALARA AYIRMA"
    ElseIf DosyaSayfa = 2 Then
        ileti = "DOSYALARA AYIRMA"
    Else
        ileti = "YAZDIRMA"
    End If
   
    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
            Application.Wait (Now + TimeValue("0:00:02"))
        End If
    Next i
   
    ActiveSheet.ShowAllData
   
    Application.ScreenUpdating = False

    MsgBox ileti & " İŞLEMİ TAMAMLANMIŞTIR....", vbInformation, "N. YEŞERTENER...."
   
End Sub
Genişletmek için tıkla ...
elinize sağlık. Ben bunu ilgili dosya için çalıştırmak istedim ama "sayfa geçerli değil" uyarısı verdi. Tam olarak nasıl kuulanacağımı anlamadı. Şekil ekleyip makroyu oraya atadım ama olmadı.
 
Merhaba,
Kodların dosyanıza uyarlanmış hali
 

Ekli dosyalar

EMRE YALÇIN' Alıntı:
elinize sağlık. Ben bunu ilgili dosya için çalıştırmak istedim ama "sayfa geçerli değil" uyarısı verdi. Tam olarak nasıl kuulanacağımı anlamadı. Şekil ekleyip makroyu oraya atadım ama olmadı.
Genişletmek için tıkla ...
Evet çalıştı. Yalnız bişey daha istesem. İlçelere göre değilde köylere göre ayrım yapsa sayfa sayfa
 
Seçiminizi düzgün yaparsanız, ister ilçelere göre isterse köylere göre sonuca ulaşırsınız.
 
güle güle kullanınız.
 
Sorununuz çözülmüş, örnek kod olarak kalsın.
Kod: 
Sub test()

    Application.ScreenUpdating = False
    Dim sAna As Worksheet, son&, koyler, sh As Worksheet
    Dim rng As Range, koy
    
    Set sAna = Sheets("Sayfa1")
    son = sAna.Cells(Rows.Count, 2).End(3).Row
    If son < 2 Then Exit Sub
    koyler = sAna.Range("B2:B" & son).Value
        
    Set rng = sAna.Range("A1:C" & son)
    
    With CreateObject("Scripting.Dictionary")
    
        For Each koy In koyler
            .Item(koy) = Null
        Next koy
        koyler = .keys

        Application.DisplayAlerts = False
        For Each sh In Worksheets
            If .exists(sh.Name) Then sh.Delete
        Next sh
        Application.DisplayAlerts = True
        
    End With
    
    If sAna.FilterMode Then sAna.ShowAllData

    For Each koy In koyler
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = koy
        rng.AutoFilter Field:=2, Criteria1:=koy
        rng.Copy Range("A1")
        Columns.AutoFit
    Next koy
        
    sAna.Select
    If sAna.AutoFilterMode Then sAna.ShowAllData
    Application.ScreenUpdating = True
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst