• DİKKAT

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

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

ocamurlu

ocamurlu

Altın Üye
Katılım
20 Haziran 2017
Mesajlar
17
Excel Vers. ve Dili
Ofis 2007
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.
 

Ekli dosyalar

Son düzenleme:
Deneyiniz.

C++: 
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
 
Teşekkürler elinize sağlık ama eski veriler silinmemesi gerekiyor o makroyu nasıl kaldırabilirim
 
Deneyiniz.

C++: 
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
 
Teşekkür ederim ama anasayfadaki verilerin silinmemesi gerekiyor
 
Başka sorun var mı?
 
#4 nolu mesajımı revize ettim. Deneyiniz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst