GRUPLARA GÖRE SAYFALARA PERSONELİ DAĞITMA

[Necdet]

Merhaba,

Aynı konu için yazılan makroyu başka bir konu belirterek hızlandırmak istediniz.
Dolayısıyla buraya makroyu ekliyorum.

Aşağıdaki kodları deneyiniz. Mevcut makroyu değil kendi kodlarımı ekliyorum.
Kodları doğrudan çalıştırabilirsiniz. "Ana Sayfa" hariç diğer sayfaları silerek devam eder.

Sub SayfaOlustur()

    Dim d, _
        Deg, _
        i   As Long, _
        j   As Integer, _
        ShA As Worksheet, _
        Sh  As Worksheet
    
    Set ShA = Sheets("Ana Sayfa")
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    If ShA.AutoFilterMode = True Then ShA.Cells.AutoFilter
    
    For Each Sh In Worksheets
        If Not Sh.Name = ShA.Name Then Sh.Delete
    Next Sh
    
    Set d = CreateObject("Scripting.Dictionary")
    
    For i = 2 To ShA.Cells(Rows.Count, "C").End(3).Row
        If Not IsError(ShA.Cells(i, "Y")) Then
            Deg = Trim(ShA.Cells(i, "Y"))
            If Not Deg = "" Then
                If Not d.exists(Deg) Then
                    d.Add Deg, ""
                    Sheets.Add After:=Sheets(Sheets.Count)
                    ActiveSheet.Name = Deg
                End If
            End If
        End If
    Next i
    
    ShA.Select
    
    ShA.Cells.AutoFilter
    
    i = ShA.Cells(Rows.Count, "C").End(3).Row
    
    Deg = d.Keys
    
    For j = 0 To UBound(Deg)
        ShA.Range("$A$1:$Y" & i).AutoFilter Field:=25, Criteria1:=Deg(j)
        ShA.Cells.Copy Sheets(Deg(j)).Range("A1")
    Next j
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    ShA.Cells.AutoFilter
    
    MsgBox d.Count & " ADET SAYFA OLUŞTURULUP AKTARILMIŞTIR.....", vbInformation, "www.excel.web.tr Necdet YEŞERTENER"
    
End Sub

 

[metin_0606]

Merhaba,

Aynı konu için yazılan makroyu başka bir konu belirterek hızlandırmak istediniz.
Dolayısıyla buraya makroyu ekliyorum.

Aşağıdaki kodları deneyiniz. Mevcut makroyu değil kendi kodlarımı ekliyorum.
Kodları doğrudan çalıştırabilirsiniz. "Ana Sayfa" hariç diğer sayfaları silerek devam eder.

Sub SayfaOlustur()

    Dim d, _
        Deg, _
        i   As Long, _
        j   As Integer, _
        ShA As Worksheet, _
        Sh  As Worksheet
   
    Set ShA = Sheets("Ana Sayfa")
   
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
   
    If ShA.AutoFilterMode = True Then ShA.Cells.AutoFilter
   
    For Each Sh In Worksheets
        If Not Sh.Name = ShA.Name Then Sh.Delete
    Next Sh
   
    Set d = CreateObject("Scripting.Dictionary")
   
    For i = 2 To ShA.Cells(Rows.Count, "C").End(3).Row
        If Not IsError(ShA.Cells(i, "Y")) Then
            Deg = Trim(ShA.Cells(i, "Y"))
            If Not Deg = "" Then
                If Not d.exists(Deg) Then
                    d.Add Deg, ""
                    Sheets.Add After:=Sheets(Sheets.Count)
                    ActiveSheet.Name = Deg
                End If
            End If
        End If
    Next i
   
    ShA.Select
   
    ShA.Cells.AutoFilter
   
    i = ShA.Cells(Rows.Count, "C").End(3).Row
   
    Deg = d.Keys
   
    For j = 0 To UBound(Deg)
        ShA.Range("$A$1:$Y" & i).AutoFilter Field:=25, Criteria1:=Deg(j)
        ShA.Cells.Copy Sheets(Deg(j)).Range("A1")
    Next j
   
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
   
    ShA.Cells.AutoFilter
   
    MsgBox d.Count & " ADET SAYFA OLUŞTURULUP AKTARILMIŞTIR.....", vbInformation, "www.excel.web.tr Necdet YEŞERTENER"
   
End Sub

[/Q
Teşekkürler necdet bey ilgi ve alakanızdan dolayı

 

[Necdet]

Sayın metin_0606 bu mesajı da silmişsiniz.

Silmeyiniz.

 

[metin_0606]

Boyle bir buton koymanizin sebebi nedir peki

 

[Necdet]

Ola ki yanlış yere yanlış mesaj attınız, farkettiniz o an silebilirsiniz.
ama bir sürü kodlar yazılşmış, formüller verilmiş, siz yararlanmışsınız, başka arkadaşların da aynı konu hakkında araştırma yaparken yararlanması gerekir.

 

[metin_0606]

Anlaşıldı merkez ama kendimce haklı nedenlerim vardı keyfimden silmedim