• DİKKAT

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

Personeli Çalıştığı Gruba Göre 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
Değerli Hocalarım bu konu ile ilgili önceden örnek bir şablon yayınlamıştım. Ancak kendi sayfamda A sütünunun olmadığını farkettim. Bu nedenle örnek sayfada çalışan makro benim sayfamda çalışmadı. Bu sefer kendi sayfamı ve makroyu paylaştım. Benim sayfama göre makroyu revize edebilirsek memnun olurum. Saygılar

Kod: 
Sub test()

Zaman = Timer

Application.DisplayAlerts = False

    For Each Sayfa In ThisWorkbook.Worksheets

        Select Case Sayfa.Name

            Case "Ana Sayfa", "data"

            ‘Case Else: Sayfa.Delete

        End Select

    Next

Application.DisplayAlerts = True

Application.ScreenUpdating = 0

    Set d = CreateObject("scripting.dictionary")

    Set s1 = Sheets("Ana Sayfa")

    a = s1.Range("A2:Y" & s1.Cells(Rows.Count, 1).End(3).Row).Value

    sy = UBound(a, 2)

        For i = 1 To UBound(a)

            If Not a(i, sy) = "" Then d(a(i, sy)) = ""

        Next i

    ReDim b(1 To UBound(a), 1 To sy)

    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 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

            Next x

        s1.[A1:Y1].Copy Sheets(S2.Name).[A1]

        S2.[A2].Resize(say, sy) = b

        S2.[A2].Resize(say, sy).Columns.AutoFit

        S2.DrawingObjects.Delete

        S2.[A2].Resize(say, sy).Borders.LineStyle = 1

        say = 0

    Next i

    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
 

Ekli dosyalar

şifreyi kaldırırsanız belki yardımcı olan biri bulunur
 
Kod: 
Sub test()
Zaman = Timer
Application.ScreenUpdating = 0
Application.DisplayAlerts = False
    For Each Sayfa In ThisWorkbook.Worksheets
        Select Case Sayfa.Name
            Case "Ana Sayfa", "ÇIKIŞ", "GİRİŞ", "PERSONEL BİLGİ FORMU"
            Case Else: Sayfa.Delete
        End Select
    Next
Application.DisplayAlerts = True

    Set d = CreateObject("scripting.dictionary")
    Set s1 = Sheets("Ana Sayfa")
    a = s1.Range("B2:Z" & s1.Cells(Rows.Count, "Z").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.[B1:Z1].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ı:
Kod: 
Sub test()
Zaman = Timer
Application.ScreenUpdating = 0
Application.DisplayAlerts = False
    For Each Sayfa In ThisWorkbook.Worksheets
        Select Case Sayfa.Name
            Case "Ana Sayfa", "ÇIKIŞ", "GİRİŞ", "PERSONEL BİLGİ FORMU"
            Case Else: Sayfa.Delete
        End Select
    Next
Application.DisplayAlerts = True

    Set d = CreateObject("scripting.dictionary")
    Set s1 = Sheets("Ana Sayfa")
    a = s1.Range("B2:Z" & s1.Cells(Rows.Count, "Z").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.[B1:Z1].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 ...
Ziynettin hocam süpersin valla ne diyeceğimi bilemedim Çok teşekkür ederim bu makro için zamanınız olduğunda yeni bir paylaşım yaptım hocam onada bakabilirseniz çok sevinirim benim işimi olursa çok kolaylaştıracak saygılar
 
hocam elinize sağlık,rica etsem hangi satır gruplanacak alanı belirliyor;yazabilirmisiniz
 
muhsar' Alıntı:
hocam elinize sağlık,rica etsem hangi satır gruplanacak alanı belirliyor;yazabilirmisiniz
Genişletmek için tıkla ...


sy = UBound(a, 2)

yerine;

sy =25 şeklinde de kullanabilirsiniz.

Burada 25 sutun no değiştirip kendinize göre uyarlarsınız.
 
çok teşekkür ederim elinize sağlık
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst