Süz ve Ayrı kaydet

[mt621]

Sistem İmprt kitabı sayfa1 deki Hücrelere girilen verilerin süzülerek B hücresindeki kod ismiyle kKitap açıp, buraya şahsi bilgilerinin girilmesi ve kod adıyla (Dosya1) adlı klasöre kaydetmesi.
B hücresindeki kod ismiyle ikinci bir Kitap açıp Sistem İmprt Kitabındaki B hücresinde süzülen tüm bilgileri alarak sistem adlı dosyaya Kod adıyla kaydetmesini istiyorum, yardımcı olursanız çok sevinirim..arkadalar yardmınıza ihtiyacım var.

 

[mt621]

Yardımcı olursanız sevinirim.

 

[mt621]

yardımcı olurmusunuz

bu konuda yardımlarınıza ihtiyacım.

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Filtre uyguladıktan sonra kodu çalıştırın.

Sub AKTAR()
    Onay = MsgBox("Bilgiler yeni çalışma kitabına aktarılacaktır. İşlemi onalıyor musunuz?", vbExclamation + vbYesNo)
    If Onay = vbYes Then
        Set K1 = ThisWorkbook
        Set S1 = K1.Sheets("SAYFA-1")
        Set K2 = Workbooks.Add(1)
        Set S2 = K2.Sheets(1)
        
        Satir = S1.Range("B" & S1.Rows.Count).End(3).Row

        S1.Range("I2:I" & Satir).Copy S2.Range("A1")
        S1.Range("D2:D" & Satir).Copy S2.Range("B1")
        S1.Range("C2:C" & Satir).Copy S2.Range("C1")
        S1.Range("N2:O" & Satir).Copy S2.Range("D1")
        S1.Range("P2:P" & Satir).Copy S2.Range("F1")
        S1.Range("Q2:S" & Satir).Copy S2.Range("I1")
        S1.Range("B2:B" & Satir).Copy S2.Range("M1")
        
        Son = S2.Cells(S2.Rows.Count, "M").End(3).Row
        S2.Range("G:G").Insert
        S2.Range("F1:I1").FillRight
        
        With S2.Range("G2:G" & Son)
            .Formula = "=DAY(F2)"
            .Value = .Value
        End With
        
        With S2.Range("H2:H" & Son)
            .Formula = "=MONTH(F2)"
            .Value = .Value
        End With
                
        With S2.Range("I2:I" & Son)
            .Formula = "=YEAR(F2)"
            .Value = .Value
        End With
                
        S2.Range("F:F").Delete
        S2.Columns("F:F").NumberFormat = "General"
        
        With S2.Range("L2:L" & Son)
            .Formula = "=IF(COUNTA(A2:K2)=11,""I"","""")"
            .Value = .Value
        End With
        Application.DisplayAlerts = False
        Dosya_Adi = S2.Range("M2") & ".xlsx"
        K2.SaveAs (K1.Path & "\Savcılık\" & Dosya_Adi)
        CreateObject("Scripting.FileSystemObject").CopyFile ActiveWorkbook.FullName, K1.Path & "\Sistem İmprt\Sistem " & Dosya_Adi
        K2.Close False
        Application.DisplayAlerts = True
    End If
End Sub

 

[mt621]

Teşekkür

Sayın Korhan bey çok teşekkür ederim çok işime yaradı. Kendimde bazı eklemeler yapıyorum.
tekrar teşekkürler iyi günler