Bilgileri Sayfalara Aktarmak.

[MrExcelMr]

Merhaba;

https://s6.dosya.tc/server3/mcz1a5/Personel_Ayirimi.xlsm.html

Ekteki örnekte covid aşısından sorumlu personellerin farklı sayfalara dağılımın yapılması için bir örnek paylaşıyorum. Konu hakkında destek olabilir misiniz.

*Excel sayfasında A1 ile G1 sütunları arasında sabit başlıklar bulunmaktadır.
*D sütunundaki Görevli Personel isimleriyle A'dan Z'ye sıralı şekilde yeni bir sayfa açılmasını ve personel isimlerine göre tüm satırları ilgili sayfalara aktarmasını yapmak istiyoruz.
*Tahmini olarak ana sayfa da 5.000 satır bilgibulunmaktadır.
*Aynı Çalışma kitabının içerisinde mevcut olan SON isimli sayfadaysa, Aşı Markaları ile Miktarının toplamlarını yazdırmak istiyoıruz.

Sağlklı Günler Dileriz.

 

[Ziynettin]

Sub test()
Dim s1 As Worksheet, s2 As Worksheet
Set dc = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("SON")

Application.ScreenUpdating = False
Application.DisplayAlerts = False

    For Each sh In ThisWorkbook.Worksheets
        Select Case sh.Name
            Case s1.Name, s2.Name
        Case Else
            sh.Delete
        End Select
    Next sh
    
Application.DisplayAlerts = True
son = s1.Range("D" & Rows.Count).End(3).Row
a = s1.Range("A1:G" & son).Value

    For i = 2 To UBound(a)
        If a(i, 4) <> "" Then dc(a(i, 4)) = ""
        If a(i, 2) <> "" Then ds(a(i, 2)) = ds(a(i, 2)) + a(i, 6)
    Next i

s2.Range("A2:B" & Rows.Count).ClearContents
s2.Range("A2:B" & Rows.Count).ClearFormats

    If ds.Count > 0 Then
        s2.[A2].Resize(ds.Count, 2) = Application.Transpose(Array(ds.keys, ds.items))
        s2.[A2].Resize(ds.Count, 2).Borders.Color = rgbSilver
    End If

If dc.Count < 1 Then MsgBox "İşlem yok", vbCritical: Exit Sub
sh = dc.keys

    For x = 0 To dc.Count - 1
        ReDim b(1 To UBound(a), 1 To 7)
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = sh(x)
        ActiveWindow.DisplayGridlines = False
            For i = 1 To UBound(a)
                If a(i, 4) = sh(x) Then
                    say = say + 1
                    For j = 1 To 7
                        b(say, j) = a(i, j)
                    Next j
                End If
            Next i
        If say > 0 Then
            s1.Range("A1:G1").Copy Sheets(sh(x)).[A1]
            Sheets(sh(x)).[A2].Resize(say, 7) = b
            Sheets(sh(x)).[A2].Resize(say, 7).EntireColumn.AutoFit
            Sheets(sh(x)).[A2].Resize(say, 7).Borders.Color = rgbSilver
        End If
        say = 0
    Next x
    
s1.Select

Application.ScreenUpdating = True
MsgBox "İşlem bitti...", vbInformation
End Sub

 

[Ziynettin]

[A-Z] sayfa sıralama

Sub test_2()
Dim s1 As Worksheet, s2 As Worksheet
Set dc = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("SON")

Application.ScreenUpdating = False
Application.DisplayAlerts = False

    For Each sh In ThisWorkbook.Worksheets
        Select Case sh.Name
            Case s1.Name, s2.Name
        Case Else
            sh.Delete
        End Select
    Next sh
    
Application.DisplayAlerts = True
son = s1.Range("D" & Rows.Count).End(3).Row
a = s1.Range("A1:G" & son).Value

    For i = 2 To UBound(a)
        If a(i, 4) <> "" Then dc(a(i, 4)) = ""
        If a(i, 2) <> "" Then ds(a(i, 2)) = ds(a(i, 2)) + a(i, 6)
    Next i

s2.Range("A2:B" & Rows.Count).ClearContents
s2.Range("A2:B" & Rows.Count).ClearFormats

    If ds.Count > 0 Then
        s2.[A2].Resize(ds.Count, 2) = Application.Transpose(Array(ds.keys, ds.items))
        s2.[A2].Resize(ds.Count, 2).Borders.Color = rgbSilver
    End If

If dc.Count < 1 Then MsgBox "İşlem yok", vbCritical: Exit Sub

sh = dc.keys

For i = 0 To UBound(sh)
    For j = i To UBound(sh)
        If sh(j) < sh(i) Then
            ww = sh(j)
            sh(j) = sh(i)
            sh(i) = ww
        End If
    Next j
Next i

    For x = 0 To dc.Count - 1
        ReDim b(1 To UBound(a), 1 To 7)
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = sh(x)
        ActiveWindow.DisplayGridlines = False
            For i = 1 To UBound(a)
                If a(i, 4) = sh(x) Then
                    say = say + 1
                    For j = 1 To 7
                        b(say, j) = a(i, j)
                    Next j
                End If
            Next i
        If say > 0 Then
            s1.Range("A1:G1").Copy Sheets(sh(x)).[A1]
            Sheets(sh(x)).[A2].Resize(say, 7) = b
            Sheets(sh(x)).[A2].Resize(say, 7).EntireColumn.AutoFit
            Sheets(sh(x)).[A2].Resize(say, 7).Borders.Color = rgbSilver
        End If
        say = 0
    Next x
    
s1.Select

Application.ScreenUpdating = True
MsgBox "İşlem bitti...", vbInformation
End Sub

 

[MrExcelMr]

Ziynettin Bey harikasınız. Çok teşekkür ederiz. Sağlıklı Günler Diliyoruz...