Dosya aç aktar

[Erdinç FIRTINA]

Değerli forum üyeleri,
Bir dosyanın Sayfa1 A sütununda yer alan isimlere göre dosyalar oluşturulmasını ve açılan dosyalara da ilgili verilerini aktarmak istiyorum.
Örnek dosya ektedir.
Yardımlarınız için şimdiden teşekkürler !!!

 

[Erdinç FIRTINA]

Sayın üyeler,
olmayacak bir şeyse hiç değilse cevap beklemeyim. Bir baka bilirseniz mutlu olacağım.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu deneyiniz. Bütün dosyalar bu dosyanızla aynı klasör içine oluşturulur. Bu sebeple masaüstünde bir klasör oluşturup dosyanızı bu klasör içine alıp makroyu çalıştırın.

Option Explicit
 
Sub KITAPLARA_AKTAR()
    Dim K1 As Workbook, K2 As Workbook, S1 As Worksheet
    Dim X As Long, Okul As Collection, Dosya_Yolu As String, Dosya As Range
    
    Application.ScreenUpdating = False
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
    Set Okul = New Collection
    
    Dosya_Yolu = K1.Path & "\"
    
    On Error Resume Next
    For X = 2 To S1.Cells(Rows.Count, 1).End(3).Row
        Okul.Add S1.Cells(X, 1), CStr(S1.Cells(X, 1))
    Next
    On Error GoTo 0
    
    For Each Dosya In Okul
        If Dir(Dosya_Yolu & Dosya) = "" Then
            Set K2 = Workbooks.Add(1)
            S1.Range("A1").AutoFilter Field:=1, Criteria1:=Dosya
            If S1.Cells(Rows.Count, 1).End(3).Row > 1 Then
                S1.Range("A1").CurrentRegion.Copy K2.Sheets(1).Range("A1")
                K2.Sheets(1).Cells.EntireColumn.AutoFit
                Application.DisplayAlerts = False
                K2.SaveAs Filename:=Dosya_Yolu & Dosya & ".xlsx", FileFormat:=xlOpenXMLWorkbook
                K2.Close False
            End If
        End If
    Next
    
    Application.DisplayAlerts = True
    S1.Range("A1").AutoFilter
    
    Application.ScreenUpdating = True
    
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

 

[Erdinç FIRTINA]

Yok yok karşılıksız ve çıkarsız emek buna denir işte !!!

Yürekten teşekkürler !!! İyi ki varsınız ...