Soru Personel Listesini Çalıştığı Birime Göre Aktarma İşlemi

[ocamurlu]

Ekteki örnek dosyada personel listesini çalıştığı birimlere göre ( C3) e den itibaren makro ile otomatik sayfa ismi ile nasıl aktarabilrim.. Not: 3. satırdan itibaren liste aktarımı yapılmasını istiyorum mümkünse) şimdiden yardımlarınız için teşekkür ederim.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Sayfalara_Aktar()
    Dim Onay As Byte, Sayfa As Worksheet, S1 As Worksheet
    Dim Dizi As Object, Veri As Variant, Son As Long
    Dim X As Long, Birim As Variant, Satir As Long
    
    Onay = MsgBox("Eski bilgilerin bulunduğu sayfaları silmek ister misiniz?" & vbCr & vbCr & _
           "EVET : Sayfaları silerek veriler yeni eklenen sayfalara aktarılır." & vbCr & _
           "HAYIR : Var olan sayfaların altına yeni veriler eklenerek işlem yapılır.", vbCritical + vbYesNo + vbDefaultButton2)
        
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    If Onay = vbYes Then
        Application.DisplayAlerts = False
        For Each Sayfa In ThisWorkbook.Worksheets
            If Sayfa.Name <> "Personel Listesi" Then Sayfa.Delete
        Next
        Application.DisplayAlerts = True
    End If
    
    Set S1 = Sheets("Personel Listesi")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    
    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
    Veri = S1.Range("C4:C" & Son).Value
    
    For X = 1 To UBound(Veri, 1)
        Dizi(Veri(X, 1)) = 1
    Next
    
    For Each Birim In Dizi.Keys
        Set Sayfa = Nothing
        On Error Resume Next
        Set Sayfa = Sheets(CStr(Birim))
        On Error GoTo 0
        If Sayfa Is Nothing Then
            Sheets.Add , Sheets(Sheets.Count)
            ActiveSheet.Name = Birim
            S1.Range("A3:O" & S1.Rows.Count).AutoFilter 3, Birim
            S1.Range("A3").CurrentRegion.Copy ActiveSheet.Range("A1")
            ActiveSheet.Cells.EntireColumn.AutoFit
            With Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
                .Formula = "=ROW(A1)"
                .Value = .Value
            End With
        Else
            Satir = Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row + 1
            S1.Range("A3:O" & S1.Rows.Count).AutoFilter 3, Birim
            Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
            If Son > 3 Then
                S1.Range("A4:O" & Son).Copy Sayfa.Range("A" & Satir)
                With Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
                    .Formula = "=ROW(A1)"
                    .Value = .Value
                End With
                ActiveSheet.Cells.EntireColumn.AutoFit
            End If
        End If
    Next

    On Error Resume Next
    S1.Select
    S1.ShowAllData
    On Error GoTo 0
    
    Onay = MsgBox("Aktarılan verileri ana sayfadan silmek ister misiniz?", vbCritical + vbYesNo + vbDefaultButton2)
    If Onay = vbYes Then
        S1.Range("A4:O" & S1.Rows.Count).ClearContents
    End If
    
    Set Sayfa = Nothing
    Set S1 = Nothing
    Set Dizi = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
End Sub

 

[ocamurlu]

Teşekkürler elinize sağlık ama eski veriler silinmemesi gerekiyor o makroyu nasıl kaldırabilirim

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Sayfalara_Aktar()
    Dim Sayfa As Worksheet, S1 As Worksheet
    Dim Dizi As Object, Veri As Variant, Son As Long
    Dim X As Long, Birim As Variant, Satir As Long
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set S1 = Sheets("Personel Listesi")
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
   
    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
    Veri = S1.Range("C4:C" & Son).Value
   
    For X = 1 To UBound(Veri, 1)
        Dizi(Veri(X, 1)) = 1
    Next
   
    For Each Birim In Dizi.Keys
        Set Sayfa = Nothing
        On Error Resume Next
        Set Sayfa = Sheets(CStr(Birim))
        On Error GoTo 0
        If Sayfa Is Nothing Then
            Sheets.Add , Sheets(Sheets.Count)
            ActiveSheet.Name = Birim
            S1.Range("A3:O" & S1.Rows.Count).AutoFilter 3, Birim
            S1.Range("A3").CurrentRegion.Copy ActiveSheet.Range("A1")
            ActiveSheet.Cells.EntireColumn.AutoFit
            With Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
                .Formula = "=ROW(A1)"
                .Value = .Value
            End With
        Else
            Satir = Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row + 1
            S1.Range("A3:O" & S1.Rows.Count).AutoFilter 3, Birim
            Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
            If Son > 3 Then
                S1.Range("A4:O" & Son).Copy Sayfa.Range("A" & Satir)
                With Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
                    .Formula = "=ROW(A1)"
                    .Value = .Value
                End With
                ActiveSheet.Cells.EntireColumn.AutoFit
            End If
        End If
    Next

    On Error Resume Next
    S1.Select
    S1.ShowAllData
    On Error GoTo 0
   
    Set Sayfa = Nothing
    Set S1 = Nothing
    Set Dizi = Nothing
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
End Sub

 

[ocamurlu]

Teşekkür ederim ama anasayfadaki verilerin silinmemesi gerekiyor

 

[Korhan Ayhan]

Başka sorun var mı?

 

[ocamurlu]

Başka sorun var mı?

Başka sorun yok ilginiz için teşekkür ederim

 

[Korhan Ayhan]

#4 nolu mesajımı revize ettim. Deneyiniz.

 

[ocamurlu]

#4 nolu mesajımı revize ettim. Deneyiniz.

teşekkürler sorun cozuldu