Çözüldü Excell Dosyamdaki Isim Ve Verileri Ayrı Excellere Çıkarma

[emrahtoprak]

Benim her ay oluşturduğum bir parmak okuma veri dosyam var. Program kişileri toplu olarak excell e atıyor. Ben her ay tek tek filtreleme yaparak kişilerin listelerini ayrı excellerde oluşturuyorum. Bunun daha basit yapabilir miyim yardımcı olur musunuz.
Adı Soyadı ve zamanı olacak her excel kişi kişi ayrılacak yanlarında da zaman yazacak. Bunu kişilere gönderiyorum. Mesai vs varsa yazıyorlar geri gönderiyorlar

 

[muygun]

Merhaba;
Örnek dosyanızı (özel isim vs.. değiştirerek);
https://dosya.co/
adresine yukleyerek linkini paylaşın.

 

[emrahtoprak]

Merhaba;
Örnek dosyanızı (özel isim vs.. değiştirerek);
https://dosya.co/
adresine yukleyerek linkini paylaşın.

Buyrun

https://dosya.co/rzygdyuc0lxf/deneme_dosyası.xlsx.html

 

[muygun]

Merhaba;
Versiyon farkı (Ofis 2003 de denendi. Sorunsuz çalışıyor) ne sonuç verir bilmiyorum ama eki deneyin.
İyi çalışmalar.

Link:
https://dosya.co/8qvmndffg2qv/emrahtoprak-deneme_dosyası.rar.html

 

[emrahtoprak]

Merhaba;
Versiyon farkı (Ofis 2003 de denendi. Sorunsuz çalışıyor) ne sonuç verir bilmiyorum ama eki deneyin.
İyi çalışmalar.

Link:
https://dosya.co/8qvmndffg2qv/emrahtoprak-deneme_dosyası.rar.html

Çok teşekkür ederim elinize emeğinize sağlık. Büyük yükten kurtardınız beni.

 

[denese]

Merhaba;
Versiyon farkı (Ofis 2003 de denendi. Sorunsuz çalışıyor) ne sonuç verir bilmiyorum ama eki deneyin.
İyi çalışmalar.

Link:
https://dosya.co/8qvmndffg2qv/emrahtoprak-deneme_dosyası.rar.html

Benim de ihtiyacım olan bir konuydu, emeğinize sağlık Sayın @muygun

 

[veyselemre]

Sub sayfalaraBol_Kaydet()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    If Dir("C:\Dosyalar", vbDirectory) = "" Then MkDir "C:\Dosyalar"

    Sheets("Sayfa1").Copy
    Set s2 = ActiveSheet
    Do
        shf = s2.Range("c2")
        son = Cells(Rows.Count, 3).End(3).Row
        [H:H].ClearContents
        For i = 2 To son
            If Cells(i, 3).Value = shf Then Cells(i, 8) = "*"
        Next i

        s2.Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = shf

        Intersect([H:H].SpecialCells(xlCellTypeBlanks).Cells, Rows("2:" & son + 1)).EntireRow.Delete
        [H:H].ClearContents
        ActiveSheet.Copy
        ActiveWorkbook.Close True, "C:\Dosyalar\" & ActiveSheet.Name

        s2.Select
        s2.Range("H" & son + 1) = "*"
        Intersect(s2.[H:H].SpecialCells(xlCellTypeConstants).Cells, s2.Range("H2:H" & son + 1)).EntireRow.Delete
        s2.[H:H].ClearContents

    Loop Until s2.Range("c2") = ""
    'ActiveWorkbook.Close False
    s2.Delete
    ActiveWorkbook.Close True, "C:\Dosyalar\TumPersonelSayfalarHalinde"
    Application.Speech.Speak ("OK")
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Sub sayfalaraBol_Kaydet2()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    If Dir("C:\Dosyalar", vbDirectory) = "" Then MkDir "C:\Dosyalar"
    Sheets("Sayfa1").Copy
    Set s2 = ActiveSheet
    Do

        shf = s2.Range("c2")
        son = Cells(Rows.Count, 3).End(3).Row
        [H:H].ClearContents
        ActiveSheet.Range("$A$1:$G" & son).AutoFilter Field:=3, Criteria1:=shf
        Intersect([H:H], [A:A].SpecialCells(xlCellTypeVisible).Cells.EntireRow, Rows("1:" & son)).Value = "*"
        Cells.AutoFilter

        s2.Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = shf
        Intersect([H:H].SpecialCells(xlCellTypeBlanks).Cells, Rows("2:" & son + 1)).EntireRow.Delete
        [H:H].ClearContents

        ActiveSheet.Copy
        ActiveWorkbook.Close True, "C:\Dosyalar\" & ActiveSheet.Name & "_"
        s2.Select
        s2.Range("H" & son + 1) = "*"
        Intersect(s2.[H:H].SpecialCells(xlCellTypeConstants).Cells, s2.Range("H2:H" & son + 1)).EntireRow.Delete
        s2.[H:H].ClearContents

    Loop Until s2.Range("c2") = ""
    'ActiveWorkbook.Close False
    s2.Delete
    ActiveWorkbook.Close True, "C:\Dosyalar\TumPersonelSayfalarHalinde_"
    Application.Speech.Speak ("OK")
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[denese]

Sub sayfalaraBol_Kaydet()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    If Dir("C:\Dosyalar", vbDirectory) = "" Then MkDir "C:\Dosyalar"

    Sheets("Sayfa1").Copy
    Set s2 = ActiveSheet
    Do
        shf = s2.Range("c2")

        s2.Copy After:=Sheets(Sheets.Count)
        Set s3 = ActiveSheet
        s3.Name = shf

        For i = 2 To Cells(Rows.Count, 3).End(3).Row
            If Cells(i, 3).Value <> shf Then Cells(i, 3).ClearContents
        Next i
        [C:C].SpecialCells(xlCellTypeBlanks).EntireRow.Delete

        For i = 2 To s2.Cells(Rows.Count, 1).End(3).Row
            If s2.Cells(i, 3).Value = shf Then s2.Cells(i, 3).ClearContents
        Next i
       
        s2.[C:C].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        s3.Copy
        ActiveWorkbook.Close True, "C:\Dosyalar\" & s3.Name

    Loop Until s2.Range("c3") = ""
    ActiveWorkbook.Close False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Sorunsuz ve hızlı çalışıyor, elinize sağlık Sayın @veyselemre