• DİKKAT

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

Sayfalara dağıtma

M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
İyi günler sayın forum üyeleri. Şimdi benim kullandığım makroda çalışma durumu etkin olanları çalıştığı şirkete göre sayfalara dağıtıyor. Ancak sayfalara dağıtırken Ana sayfadaki tablonun satır ve sütün genişliklerine bağlı kalmadan dağıtıyor. Buda dağıttığı sayfalarda güzel bir görüntü oluşturmuyor. Çalıştıran kod ekli çalışmanın içinde. Buna bir çözüm bulabilir miyiz. Saygılar NOT: çalıştığım sayfadaki satır sayısı 5000 kişi
 

Ekli dosyalar

Kod: 
Sub test()
Zaman = Timer
Application.ScreenUpdating = 0
Application.DisplayAlerts = False
    For Each sayfa In ThisWorkbook.Worksheets
        Select Case sayfa.Name
            Case "ANA", "AJANDA", "YEDEK", "İNDEX", "ANA SAYFA", _
                 "ÇIKIŞ", "GİRİŞ", "ANA SAYFA2", "PERSONEL BİLGİ FORMU", "İCMAL"
            Case Else: sayfa.Delete
        End Select
    Next
Application.DisplayAlerts = True
    Set d = CreateObject("scripting.dictionary")
    Set s1 = Sheets("ANA SAYFA")
    a = s1.Range("A2:X" & s1.Cells(Rows.Count, "X").End(3).Row).Value
    sy = UBound(a, 2)
        For i = 1 To UBound(a)
       If Application.IsText(a(i, sy)) = True Then
            If Not IsEmpty(a(i, sy)) Then
            d(a(i, sy)) = ""
            End If
        End If
        Next i
    ReDim b(1 To UBound(a), 1 To sy)
    If d.Count > 0 Then
    For i = 0 To d.Count - 1
        Set S2 = Sheets.Add
        S2.Move After:=Worksheets(Worksheets.Count)
        S2.Name = d.keys()(i)
            For x = 1 To UBound(a)
            If Application.IsText(a(x, sy)) = True Then
                If a(x, 23) = "Etkin" Then
                    If a(x, sy) = S2.Name Then
                        say = say + 1
                        For y = 1 To sy
                            b(say, y) = a(x, y)
                        Next y
                    End If
                End If
            End If
            Next x
        s1.[A1:Y1].Copy Sheets(S2.Name).[A1]
        If say > 0 Then
        S2.[A2].Resize(say, sy) = b
        For j = 1 To UBound(a, 2)
            S2.Columns(j).ColumnWidth = s1.Columns(j).ColumnWidth
        Next j
        S2.Rows(1).RowHeight = s1.Rows(1).RowHeight
        S2.[A2].Resize(say, sy).RowHeight = s1.Rows(2).RowHeight
        S2.[A2].Resize(say, sy).Borders.LineStyle = 1
        End If
        S2.DrawingObjects.Delete
        say = 0
    Next i
    End If
    s1.Select
Application.ScreenUpdating = 1
MsgBox "Veriler sayfalara aktarılmıştır." & Chr(10) & Chr(10) & _
       "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 
Ziynettin' Alıntı:
Kod: 
Sub test()
Zaman = Timer
Application.ScreenUpdating = 0
Application.DisplayAlerts = False
    For Each sayfa In ThisWorkbook.Worksheets
        Select Case sayfa.Name
            Case "ANA", "AJANDA", "YEDEK", "İNDEX", "ANA SAYFA", _
                 "ÇIKIŞ", "GİRİŞ", "ANA SAYFA2", "PERSONEL BİLGİ FORMU", "İCMAL"
            Case Else: sayfa.Delete
        End Select
    Next
Application.DisplayAlerts = True
    Set d = CreateObject("scripting.dictionary")
    Set s1 = Sheets("ANA SAYFA")
    a = s1.Range("A2:X" & s1.Cells(Rows.Count, "X").End(3).Row).Value
    sy = UBound(a, 2)
        For i = 1 To UBound(a)
       If Application.IsText(a(i, sy)) = True Then
            If Not IsEmpty(a(i, sy)) Then
            d(a(i, sy)) = ""
            End If
        End If
        Next i
    ReDim b(1 To UBound(a), 1 To sy)
    If d.Count > 0 Then
    For i = 0 To d.Count - 1
        Set S2 = Sheets.Add
        S2.Move After:=Worksheets(Worksheets.Count)
        S2.Name = d.keys()(i)
            For x = 1 To UBound(a)
            If Application.IsText(a(x, sy)) = True Then
                If a(x, 23) = "Etkin" Then
                    If a(x, sy) = S2.Name Then
                        say = say + 1
                        For y = 1 To sy
                            b(say, y) = a(x, y)
                        Next y
                    End If
                End If
            End If
            Next x
        s1.[A1:Y1].Copy Sheets(S2.Name).[A1]
        If say > 0 Then
        S2.[A2].Resize(say, sy) = b
        For j = 1 To UBound(a, 2)
            S2.Columns(j).ColumnWidth = s1.Columns(j).ColumnWidth
        Next j
        S2.Rows(1).RowHeight = s1.Rows(1).RowHeight
        S2.[A2].Resize(say, sy).RowHeight = s1.Rows(2).RowHeight
        S2.[A2].Resize(say, sy).Borders.LineStyle = 1
        End If
        S2.DrawingObjects.Delete
        say = 0
    Next i
    End If
    s1.Select
Application.ScreenUpdating = 1
MsgBox "Veriler sayfalara aktarılmıştır." & Chr(10) & Chr(10) & _
       "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
Genişletmek için tıkla ...
Teşekkürler ziynettin hocam çok güzel olmuş yalnız Y sütunudaki gruplarıda ekleyebilirmiz dağılıma
 
Ziynettin' Alıntı:
Kod: 
Sub test()
Zaman = Timer
Application.ScreenUpdating = 0
Application.DisplayAlerts = False
    For Each sayfa In ThisWorkbook.Worksheets
        Select Case sayfa.Name
            Case "ANA", "AJANDA", "YEDEK", "İNDEX", "ANA SAYFA", _
                 "ÇIKIŞ", "GİRİŞ", "ANA SAYFA2", "PERSONEL BİLGİ FORMU", "İCMAL"
            Case Else: sayfa.Delete
        End Select
    Next
Application.DisplayAlerts = True
    Set d = CreateObject("scripting.dictionary")
    Set s1 = Sheets("ANA SAYFA")
    a = s1.Range("A2:X" & s1.Cells(Rows.Count, "X").End(3).Row).Value
    sy = UBound(a, 2)
        For i = 1 To UBound(a)
       If Application.IsText(a(i, sy)) = True Then
            If Not IsEmpty(a(i, sy)) Then
            d(a(i, sy)) = ""
            End If
        End If
        Next i
    ReDim b(1 To UBound(a), 1 To sy)
    If d.Count > 0 Then
    For i = 0 To d.Count - 1
        Set S2 = Sheets.Add
        S2.Move After:=Worksheets(Worksheets.Count)
        S2.Name = d.keys()(i)
            For x = 1 To UBound(a)
            If Application.IsText(a(x, sy)) = True Then
                If a(x, 23) = "Etkin" Then
                    If a(x, sy) = S2.Name Then
                        say = say + 1
                        For y = 1 To sy
                            b(say, y) = a(x, y)
                        Next y
                    End If
                End If
            End If
            Next x
        s1.[A1:Y1].Copy Sheets(S2.Name).[A1]
        If say > 0 Then
        S2.[A2].Resize(say, sy) = b
        For j = 1 To UBound(a, 2)
            S2.Columns(j).ColumnWidth = s1.Columns(j).ColumnWidth
        Next j
        S2.Rows(1).RowHeight = s1.Rows(1).RowHeight
        S2.[A2].Resize(say, sy).RowHeight = s1.Rows(2).RowHeight
        S2.[A2].Resize(say, sy).Borders.LineStyle = 1
        End If
        S2.DrawingObjects.Delete
        say = 0
    Next i
    End If
    s1.Select
Application.ScreenUpdating = 1
MsgBox "Veriler sayfalara aktarılmıştır." & Chr(10) & Chr(10) & _
       "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
Genişletmek için tıkla ...

sy = UBound(a, 2)
sn.hocam;kod da yukarıdaki kısmı kolon sıra no ile değiştirip gruplama yapılan sütunu değiştirebiliyorum fakat seçtiğim sütunda kesiyor.yani sy = 7
şeklinde 7.sütuna göre grupla dediğimde işlemi yapıyor fakat 7.sütundan sonraki sütunları getirmiyor,

rica etsem hatayı nerde yapıyorum bakabilirmisiniz
 

Ekli dosyalar

muhsar' Alıntı:
sy = UBound(a, 2)
sn.hocam;kod da yukarıdaki kısmı kolon sıra no ile değiştirip gruplama yapılan sütunu değiştirebiliyorum fakat seçtiğim sütunda kesiyor.yani sy = 7
şeklinde 7.sütuna göre grupla dediğimde işlemi yapıyor fakat 7.sütundan sonraki sütunları getirmiyor,

rica etsem hatayı nerde yapıyorum bakabilirmisiniz
Genişletmek için tıkla ...

Bu şekilde kullanın.

Kod: 
Sub test_G()
Zaman = Timer
Application.ScreenUpdating = 0
Application.DisplayAlerts = False
    For Each sayfa In ThisWorkbook.Worksheets
        Select Case sayfa.Name
            Case "ANA", "AJANDA", "YEDEK", "İNDEX", "ANA SAYFA", "ÇIKIŞ", "GİRİŞ", "ANA SAYFA2", "PERSONEL BİLGİ FORMU", "İCMAL"
            Case Else: sayfa.Delete
        End Select
    Next
Application.DisplayAlerts = True

    Set d = CreateObject("scripting.dictionary")
    Set s1 = Sheets("ANA SAYFA")
    a = s1.Range("A2:X" & s1.Cells(Rows.Count, "X").End(3).Row).Value
    sy = UBound(a, 2)
    col = 7
        For i = 1 To UBound(a)
       If Application.IsText(a(i, col)) = True Then
            If Not IsEmpty(a(i, col)) Then
            d(a(i, col)) = ""
            End If
        End If
        Next i
    ReDim b(1 To UBound(a), 1 To sy)
    If d.Count > 0 Then
    For i = 0 To d.Count - 1
        Set S2 = Sheets.Add
        S2.Move After:=Worksheets(Worksheets.Count)
        S2.Name = d.keys()(i)
            For x = 1 To UBound(a)
            If Application.IsText(a(x, col)) = True Then
                If a(x, 23) = "Etkin" Then
                    If a(x, col) = S2.Name Then
                        say = say + 1
                        For y = 1 To sy
                            b(say, y) = a(x, y)
                        Next y
                    End If
                End If
            End If
            Next x
        s1.[A1:Y1].Copy Sheets(S2.Name).[A1]
        If say > 0 Then
        S2.[A2].Resize(say, sy) = b
        S2.[A2].Resize(say, sy).Columns.AutoFit
        S2.[A2].Resize(say, sy).Borders.LineStyle = 1
        End If
        S2.DrawingObjects.Delete
        say = 0
    Next i
    End If
    s1.Select
Application.ScreenUpdating = 1
MsgBox "Veriler sayfalara aktarılmıştır." & Chr(10) & Chr(10) & _
       "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 
Ziynettin' Alıntı:
Bu şekilde kullanın.

Kod: 
Sub test_G()
Zaman = Timer
Application.ScreenUpdating = 0
Application.DisplayAlerts = False
    For Each sayfa In ThisWorkbook.Worksheets
        Select Case sayfa.Name
            Case "ANA", "AJANDA", "YEDEK", "İNDEX", "ANA SAYFA", "ÇIKIŞ", "GİRİŞ", "ANA SAYFA2", "PERSONEL BİLGİ FORMU", "İCMAL"
            Case Else: sayfa.Delete
        End Select
    Next
Application.DisplayAlerts = True

    Set d = CreateObject("scripting.dictionary")
    Set s1 = Sheets("ANA SAYFA")
    a = s1.Range("A2:X" & s1.Cells(Rows.Count, "X").End(3).Row).Value
    sy = UBound(a, 2)
    col = 7
        For i = 1 To UBound(a)
       If Application.IsText(a(i, col)) = True Then
            If Not IsEmpty(a(i, col)) Then
            d(a(i, col)) = ""
            End If
        End If
        Next i
    ReDim b(1 To UBound(a), 1 To sy)
    If d.Count > 0 Then
    For i = 0 To d.Count - 1
        Set S2 = Sheets.Add
        S2.Move After:=Worksheets(Worksheets.Count)
        S2.Name = d.keys()(i)
            For x = 1 To UBound(a)
            If Application.IsText(a(x, col)) = True Then
                If a(x, 23) = "Etkin" Then
                    If a(x, col) = S2.Name Then
                        say = say + 1
                        For y = 1 To sy
                            b(say, y) = a(x, y)
                        Next y
                    End If
                End If
            End If
            Next x
        s1.[A1:Y1].Copy Sheets(S2.Name).[A1]
        If say > 0 Then
        S2.[A2].Resize(say, sy) = b
        S2.[A2].Resize(say, sy).Columns.AutoFit
        S2.[A2].Resize(say, sy).Borders.LineStyle = 1
        End If
        S2.DrawingObjects.Delete
        say = 0
    Next i
    End If
    s1.Select
Application.ScreenUpdating = 1
MsgBox "Veriler sayfalara aktarılmıştır." & Chr(10) & Chr(10) & _
       "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
Genişletmek için tıkla ...


çok teşekkür ederim elinize sağlık
 
Ziynettin' Alıntı:
a = s1.Range("A2:X" & s1.Cells(Rows.Count, "X").End(3).Row).Value .... X yerine Y olarak yazın.
Genişletmek için tıkla ...
O şekilde yapına dağılımı şirkete göre değil gruplara göre yapıyor zıynettin hocam
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst