Klasör Bazlı Tarama Yaparak Farklı Kaydet

[Rorschach159]

Selamlar,

D klasöründe içerisinde 9 alt klasör var ve bunlara farklı kaydet ile kayıt yapmak istiyorum.
Excel çalışma kitabım 6 çalışma sayfasından oluşuyor.
Şimdi benim burada istediğim şu şekilde ben butona bastığım anda "D:\Deskop\2021-FATURALAR" şu klasörde ilgili müdürlük adını arayacak daha sonra bu klasörün içine kendisi firma adı ile yeni bir klasör oluşturup içine kayıt yapacak.

-Tarama yapıp içine kaydedeceği müdürlük ismi evrakta BİLGİ GİRİŞİ C2 hücresinde yer alıyor.
-Firma adı C40, fatura tarihi C39, fatura no C38 hücresinde.

Kayıt yaptığım klasör adı "firma ismi-Fatura Tarihi-Fatura No" şeklinde yer alıyor. İçerisinde de 6 sayfalık exceldeki matbu formlar yer alacak.

 

[ÖmerFaruk]

Kayıt yaptığım klasör adı "firma ismi-Fatura Tarihi-Fatura No" şeklinde yer alıyor. İçerisinde de 6 sayfalık exceldeki matbu formlar yer alacak.

Farklı Kaydedilecek mevcut açık dosyanın ismi mi bu şekilde olacak yoksa yazdığınız klasörün ismi mi?
Eğer klasör ismiyse dosya adı ne olacak?

Aşağıdaki halini deneyin bu arada

Sub YeniDosya()
Dim FSO As Object, xFolder As Object

    If [C2] = "" Or [C40] = "" Or [C39] = "" Or [C38] = "" Then MsgBox "Eksik Veri Var": Exit Sub
    
    Kaynak = "D:\Deskop\2021-FATURALAR"
    Kaynak = Kaynak & Application.PathSeparator & Range("C2").Value
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(Kaynak) = False Then: MsgBox Range("C2") & " isimli müdürlüğe ait klasör yok": Exit Sub
    
    Kaynak = Kaynak & Application.PathSeparator & Range("C40")
    If FSO.FolderExists(Kaynak) = False Then MkDir Kaynak
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Kaynak & "\" & Format([C39], "yyyymmdd") & " - " & [C38] & " " & Replace(ThisWorkbook.Name, "xlsm", "xlsx"), 51
    Application.DisplayAlerts = True
End Sub

 

[Rorschach159]

İlgili hücreler dolu olmasına rağmen eksik veri var hatası alıyorum. C2 hücresindeki alan düşeyara formülü ile geliyor açılır liste tanımlı o yüzden boş hücre mi görüyor acaba?

O cümleyi hatalı kurmuşum senaryo şu şekilde "firma ismi-Fatura Tarihi-Fatura No" şeklinde klasör açıp içine 6 sayfayı tek tek kayıt yapacağım. Mesela Ahmet Mehmet-01.01.2021-0026 isimli klasör altında ön izin belgesi, ihtiyaç listesi gibi evraklar ayrı ayrı kayıt olacak. Asıl çalıştığım kitapta hepsi bir arada ben farklı kaydet ile bunları teker teker kayıt yapmak istiyorum. @ÖmerFaruk

 

[Rorschach159]

Problemi anladım tamam ben senaryoyu yanlış anlattım size. Bilgi Girişi sayfasından her sayfaya veriler geliyor aslında ben bilgi girişi sayfasını değil de ön izin belgesi sayfasını farklı kaydet yapmak istiyorum. Klasör için gerekli tüm bilgiler BİLGİ GİRİŞİ isimle sayfada.

Şimdi firma adını yazıyor klasör yapıyor ama fatura tarihi ve numarasını yazmıyor klasör adına @ÖmerFaruk

 

[ÖmerFaruk]

Deneyiniz.

Sub YeniDosya()
Dim FSO As Object, xFolder As Object, Sh As Worksheet, Sayfa As Worksheet

    Set Sh = Worksheets("Bilgi Girişi")
    If WorksheetFunction.CountA(Sh.Range("C2,C38,C39,C40")) < 4 Then MsgBox "Eksik Veri Var": Exit Sub

    Kaynak = "D:\Deskop\2021-FATURALAR"
    Kaynak = Kaynak & Application.PathSeparator & Sh.Range("C2").Value
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(Kaynak) = False Then: MsgBox Sh.Range("C2") & " isimli müdürlüğe ait klasör yok": Exit Sub
    
    Kaynak = Kaynak & Application.PathSeparator & Sh.Range("C40") & " - " & Format(Sh.[C39], "yyyymmdd") & " - " & Sh.[C38]
    If FSO.FolderExists(Kaynak) = False Then MkDir Kaynak

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    For Each Sayfa In Worksheets
        If Sayfa.Name <> "Bilgi Girişi" Then
                Sayfa.Copy
                ActiveWorkbook.SaveAs Kaynak & "\" & Sayfa.Name, 51
                ActiveWorkbook.Close SaveChanges:=False
        End If
    Next Sayfa
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

 

[Rorschach159]

Hocam harika çalıştı tam istediğim gibi ama "ActiveWorkbook.SaveAs Kaynak & "\" & Sayfa.Name, 51" şu satırda debug'a düştü. Ağaşıdaki özellikler Makro içermeyen kitaba kaydedilemez dedi VB Projesi hatası verdi @ÖmerFaruk

 

[ÖmerFaruk]

Orjinal dosyanızda o sayfalarda VBA kodu var mı?

 

[Rorschach159]

Orjinal dosyanızda o sayfalarda VBA kodu var mı?

Evet hocam hepsinde makrolar var.
Tarih formatını gg.aa.yyyy şekilde yapmak için ilgili yere bu formatta yazsam olur mu?

 

[ÖmerFaruk]

Farklo dosya olarak kaydedilecek sayafalardan makroları kaldırırsanız sorun düzelir

 

[Rorschach159]

Farklo dosya olarak kaydedilecek sayafalardan makroları kaldırırsanız sorun düzelir

Onu kaldıramam ki hocam çalışıyorlar arka planda satır gizleme yapıyorum falan çıktılar alıyorum

 

[ÖmerFaruk]

Farklı kaydedince de Makro İçerebilen (xlsm) olarak mı kaydetmek istiyorsunuz?

 

[Rorschach159]

Hocam kaydedeceğim dosyada fark etmiyor kaydetsin yeter. Makrosuz da olabilir makrolu da @ÖmerFaruk

 

[ÖmerFaruk]

Aşağıdaki kısmı verdiğim şekilde revize edin.

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    For Each Sayfa In Worksheets
        If Sayfa.Name <> "Bilgi Girişi" Then
                Sayfa.Copy
                DosyaAd = Kaynak & "\" & Sayfa.Name & ".xlsx"
                ActiveWorkbook.SaveAs DosyaAd, FileFormat:=51
                ActiveWorkbook.Close SaveChanges:=False
        End If
    Next Sayfa
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True

 

[Rorschach159]

Çalışıyor çok teşekkür ederim emeğinize sağlık @ÖmerFaruk

 

[Rorschach159]

Hocam bu kodda tek tek kayıt yaptığımız sayfalarda bazı formüllü alanlar AD olarak geliyor o neden olabilir? @ÖmerFaruk
Bilgi sayfasına girdiğim bilgiler diğer sayfalara formüllerle geliyor bazı formülleri ben kendim ekledim. Örnek veriyor sayı yazıyorum yazı ile yazılmış halini veriyor