Çözüldü Malzeme Bilgisine Göre Veri Aktarımı,

[Utekiner]

Selamlar,

A Sütunundaki Malzeme Adlarına göre yeni sayfa oluşturmasını ve Ana Sayfadaki bilgilerini silerek, malzemeye göre verilerini ilgili sayfalara aktarılmasını istiyorum. Bu işlemi nasıl yapabilirim.
Başlıklar açılan tüm sayfalarda aynı olmalıdır.
Satır Sayısı : 250 adet olup Malzeme ise 50 çeşittir.

Konu hakkında desteklerinizi rica ediyorum.

 

[Korhan Ayhan]

@İdris SERDAR beyin paylaşımını kullanabilirsiniz.

https://www.excelgurusu.com/sayfalara-dagit-macro/

 

[Utekiner]

@Korhan Ayhan Bey öncelikle teşekkür ederim.
Örnekte Sayfalar daha önce oluşturulmuş ve Ana sayfadaki veriler aktarılıyor. Benim isteğim Sayfaları butona tıkladığımda otomatik oluşturması ve Ana sayfadaki verilerin aktarılması sonrası verilerin silinmesidir.

 

[Utekiner]

@Korhan Ayhan Bey yardımcı olabilir misin.

 

[Korhan Ayhan]

Dosyanızda "Ana Sayfa" isimli sayfa olmalıdır. Kod içinde sayfa adını düzenleyip kullanabilirsiniz.

Kod içindeki silme işlemleri için onay vermeniz gerekiyor. Böylece veri güvenliği sizin kontrolünüzde olacaktır.

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, Malzeme As Variant, Satir As Long
    
    Onay = MsgBox("Eski bilgilerin bulunduğu sayfaları silmek ister misiniz?" & Chr(10) & Chr(10) & _
           "EVET : Sayfaları silerek veriler yeni eklenen sayfalara aktarılır." & Chr(10) & _
           "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 <> "Ana Sayfa" Then Sayfa.Delete
        Next
        Application.DisplayAlerts = True
    End If
    
    Set S1 = Sheets("Ana Sayfa")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:A" & Son).Value
    
    For X = 1 To UBound(Veri, 1)
        Dizi(Veri(X, 1)) = 1
    Next
    
    For Each Malzeme In Dizi.Keys
        Set Sayfa = Nothing
        On Error Resume Next
        Set Sayfa = Sheets(CStr(Malzeme))
        On Error GoTo 0
        If Sayfa Is Nothing Then
            Sheets.Add , Sheets(Sheets.Count)
            ActiveSheet.Name = Malzeme
            S1.Range("A1:E" & S1.Rows.Count).AutoFilter 1, Malzeme
            S1.Range("A1").CurrentRegion.Copy ActiveSheet.Range("A1")
            ActiveSheet.Cells.EntireColumn.AutoFit
        Else
            Satir = Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row + 1
            S1.Range("A1:E" & S1.Rows.Count).AutoFilter 1, Malzeme
            Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
            If Son > 1 Then
                S1.Range("A2:E" & Son).Copy Sayfa.Range("A" & Satir)
                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("A2:E" & 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

 

[Utekiner]

Sn. @Korhan Ayhan Bey desteğiniz için teşekkür ederim.

 

[Utekiner]

@Korhan Ayhan Soru kısmını Çözüldü olarak seçemiyorum. Düzeltebilir misiniz.