Bir dosyadakı sayfaları ayrı ayrı excel dosyalarına kaydettirme.

doganayfidaan · 12 Mart 2023

Merhaba,

Sub DosyalariKaydet()
Dim kayitKonumu As String
Dim dosyaAyirici As String
If InStr(Application.OperatingSystem, "Mac") > 0 Then
kayitKonumu = MacKayitKonumu()
dosyaAyirici = "/"
Else
kayitKonumu = "C:\KayitKlasoru\"
dosyaAyirici = "\"
End If

If Right(kayitKonumu, 1) <> dosyaAyirici Then kayitKonumu = kayitKonumu & dosyaAyirici

Dim ws As Worksheet
Dim dosyaAdi As String
Dim tarih As String
Dim sonTarih As String
sonTarih = ""

For Each ws In ThisWorkbook.Worksheets
If ws.Index < 5 Then ' 5. sayfadan önceki sayfaları atla
'Continue For ' Mac'te çalışmıyor, yerine If-Then bloğu içinde kullanılabilir
If ws.Index = 4 Then
Exit For ' 5. sayfaya kadar olan sayfaları atladıktan sonra döngüden çık
Else
GoTo sonraki_ws ' Bir sonraki sayfaya atla
End If
End If

tarih = Format(ws.Range("A9").Value, "yyyy-mm-dd") ' A9 hücresindeki tarihi yyyy-mm-dd formatına dönüştürür

If tarih <> sonTarih Then
dosyaAdi = kayitKonumu & tarih & ".xlsx"
ThisWorkbook.SaveCopyAs dosyaAdi
sonTarih = tarih
Else
Dim wb As Workbook
Set wb = Workbooks.Open(dosyaAdi)
ws.Copy After:=wb.Sheets(wb.Sheets.Count)
wb.Save
wb.Close
End If

sonraki_ws:
Next

MsgBox "Dosyalar başarıyla kaydedildi."
End Sub

Function MacKayitKonumu() As String
Dim scriptStr As String
scriptStr = "return POSIX path of (path to desktop folder as text)"
MacKayitKonumu = MacScript(scriptStr)
End Function

Elimde bçyle bir kod var yapay zeka yardımı ile yazdım.Bu kod excel dosyamdaki sayfları 5. sayfadan itibaren tarih ve dosya ismiyle farklı bir excell olarak kaydetmesini istiyorum fakat bu kod ne mac de nede widonwsda çalışmamakta. Dosya konumlarını doğru yazdığıma eminim ne sorunu olabilir kodun?

RBozkurt · 12 Mart 2023

Merhaba deneyiniz,
AI için algoritma önemli..

Dosyanın bulunduğu dizinde çalışır, klasör açar.

C++:

Sub AyirSayfalar()

    Dim DosyaAdi As String
    Dim DosyaYolu As String
    Dim YeniKlasor As String
   
    DosyaAdi = ActiveWorkbook.Name
    DosyaYolu = ActiveWorkbook.Path
   
    YeniKlasor = DosyaYolu & "\AYIR"
    If Dir(YeniKlasor, vbDirectory) = "" Then
        MkDir YeniKlasor
    End If
   
    Dim SayfaListesi As String
    Dim i As Integer
   
    SayfaListesi = "Lütfen kaydedilecek sayfaların numaralarını virgülle ayırarak girin:" & vbCrLf & vbCrLf
    For i = 1 To ActiveWorkbook.Sheets.Count
        SayfaListesi = SayfaListesi & i & " - " & ActiveWorkbook.Sheets(i).Name & vbCrLf
    Next i
   
    Dim KaydedilecekSayfalar As Variant
    KaydedilecekSayfalar = InputBox(SayfaListesi, "Sayfaları Ayır", "")
   
    Dim SayfaNumaralari As Variant
    SayfaNumaralari = Split(KaydedilecekSayfalar, ",")
   
    Dim SayfaNumarasi As Integer
    Dim SayfaAdi As String
    Dim YeniDosyaAdi As String
   
    For i = LBound(SayfaNumaralari) To UBound(SayfaNumaralari)
        SayfaNumarasi = Val(SayfaNumaralari(i))
        SayfaAdi = ActiveWorkbook.Sheets(SayfaNumarasi).Name
        YeniDosyaAdi = YeniKlasor & "\" & SayfaAdi & ".xlsx"
        ActiveWorkbook.Sheets(SayfaNumarasi).Copy
        ActiveWorkbook.SaveAs Filename:=YeniDosyaAdi, FileFormat:=xlOpenXMLWorkbook
        ActiveWorkbook.Close False
    Next i
   
End Sub

RBozkurt · 12 Mart 2023

Kod:

Sub AyirSayfalar()

    ' Dosya yolunu ve adını al
    Dim DosyaAdi As String
    Dim DosyaYolu As String
    Dim YeniKlasor As String
    
    DosyaAdi = ActiveWorkbook.Name
    DosyaYolu = ActiveWorkbook.Path
    
    ' Yeni bir klasör oluştur
    YeniKlasor = DosyaYolu & "\AYIR"
    If Dir(YeniKlasor, vbDirectory) = "" Then
        MkDir YeniKlasor
    End If
    
    ' Tüm sayfaların listesini göster
    Dim SayfaListesi As String
    Dim i As Integer
    
    SayfaListesi = "Lütfen kaydedilecek sayfaların numaralarını virgülle ayırarak girin:" & vbCrLf & vbCrLf
    For i = 1 To ActiveWorkbook.Sheets.Count
        SayfaListesi = SayfaListesi & i & " - " & ActiveWorkbook.Sheets(i).Name & vbCrLf
    Next i
    
    Dim KaydedilecekSayfalar As Variant
    KaydedilecekSayfalar = InputBox(SayfaListesi, "Sayfaları Ayır", "")
    
    ' Seçilen sayfaları ayrı ayrı kaydet
    If KaydedilecekSayfalar <> "" Then
        Dim SayfaNumaralari As Variant
        SayfaNumaralari = Split(KaydedilecekSayfalar, ",")
        
        Dim SayfaNumarasi As Integer
        Dim SayfaAdi As String
        Dim YeniDosyaAdi As String
        
        For i = LBound(SayfaNumaralari) To UBound(SayfaNumaralari)
            SayfaNumarasi = Val(SayfaNumaralari(i))
            If SayfaNumarasi > 0 And SayfaNumarasi <= ActiveWorkbook.Sheets.Count Then
                SayfaAdi = ActiveWorkbook.Sheets(SayfaNumarasi).Name
                YeniDosyaAdi = YeniKlasor & "\" & SayfaAdi & ".xlsx"
                ActiveWorkbook.Sheets(SayfaNumarasi).Copy
                ActiveWorkbook.SaveAs Filename:=YeniDosyaAdi, FileFormat:=xlOpenXMLWorkbook
                ActiveWorkbook.Close False
            Else
                MsgBox "Geçersiz sayfa numarası: " & SayfaNumarisi, vbCritical, "Hata"
            End If
        Next i
        
        MsgBox "Sayfalar başarıyla kaydedildi.", vbInformation, "Tamamlandı"
    Else
        MsgBox "Kaydedilecek sayfaları belirtmediniz.", vbExclamation, "Uyarı"
    End If
    
End Sub

doganayfidaan · 12 Mart 2023

hocam cok güzel windowsda calısşıyor ama mac cihazimda hata alıyorum.Klasör oluştururken

RBozkurt · 12 Mart 2023

Klasör oluşturma protokolünü iptal edin, aynı klasöre kaydeder,

Ya da klasörü el ile açıp kayıt yolunu sabitleyin.

doganayfidaan · 12 Mart 2023

çok bi bilgim yok düzeltip iletme şansınız var mı?

doganayfidaan · 12 Mart 2023

Şöyle olabilir mi , klasörün içine excel dosyasını koydum ve bi klasör daha oluşturdum adi ARŞİV olsun arşive kaydetsin

RBozkurt · 12 Mart 2023

Deneyiniz,
Bulunduğu dizinde ARŞİV klasörüne kayıt yapması gerekir.

Kod:

Sub AyirSayfalar()

    Dim DosyaAdi As String
    Dim DosyaYolu As String
    Dim YeniKlasor As String
  
    DosyaAdi = ActiveWorkbook.Name
    DosyaYolu = ActiveWorkbook.Path
  
    YeniKlasor = DosyaYolu & "\ARŞİV"
  
    Dim SayfaListesi As String
    Dim i As Integer
  
    SayfaListesi = "Lütfen kaydedilecek sayfaların numaralarını virgülle ayırarak girin:" & vbCrLf & vbCrLf
    For i = 1 To ActiveWorkbook.Sheets.Count
        SayfaListesi = SayfaListesi & i & " - " & ActiveWorkbook.Sheets(i).Name & vbCrLf
    Next i
  
    Dim KaydedilecekSayfalar As Variant
    KaydedilecekSayfalar = InputBox(SayfaListesi, "Sayfaları Ayır", "")
  
    Dim SayfaNumaralari As Variant
    SayfaNumaralari = Split(KaydedilecekSayfalar, ",")
  
    Dim SayfaNumarasi As Integer
    Dim SayfaAdi As String
    Dim YeniDosyaAdi As String
  
    For i = LBound(SayfaNumaralari) To UBound(SayfaNumaralari)
        SayfaNumarasi = Val(SayfaNumaralari(i))
        SayfaAdi = ActiveWorkbook.Sheets(SayfaNumarasi).Name
        YeniDosyaAdi = YeniKlasor & "\" & SayfaAdi & ".xlsx"
        ActiveWorkbook.Sheets(SayfaNumarasi).Copy
        ActiveWorkbook.SaveAs Filename:=YeniDosyaAdi, FileFormat:=xlOpenXMLWorkbook
        ActiveWorkbook.Close False
    Next i
  
End Sub

RBozkurt · 12 Mart 2023

Edit: Çalışmadığı için kaldırıldı.

WinOS ve MacOS deneyiniz.
2 makro var aynı modüle ekleyin.

doganayfidaan · 12 Mart 2023

elinize sağlık hocam cok sağ olun

doganayfidaan · 12 Mart 2023

RBozkurt' Alıntı:

WinOS ve MacOS deneyiniz.
2 makro var aynı modüle ekleyin.

Kod:

Sub AyirSayfalar()

    Dim DosyaAdi As String
    Dim DosyaYolu As String
    Dim YeniKlasor As String

    DosyaAdi = ActiveWorkbook.Name
    DosyaYolu = ActiveWorkbook.Path

    YeniKlasor = DosyaYolu & "\ARŞİV"
    Call ArşivKlasörüOluştur

    Dim SayfaListesi As String
    Dim i As Integer

    SayfaListesi = "Lütfen kaydedilecek sayfaların numaralarını virgülle ayırarak girin:" & vbCrLf & vbCrLf
    For i = 1 To ActiveWorkbook.Sheets.Count
        SayfaListesi = SayfaListesi & i & " - " & ActiveWorkbook.Sheets(i).Name & vbCrLf
    Next i

    Dim KaydedilecekSayfalar As Variant
    KaydedilecekSayfalar = InputBox(SayfaListesi, "Sayfaları Ayır", "")

    Dim SayfaNumaralari As Variant
    SayfaNumaralari = Split(KaydedilecekSayfalar, ",")

    Dim SayfaNumarasi As Integer
    Dim SayfaAdi As String
    Dim YeniDosyaAdi As String

    For i = LBound(SayfaNumaralari) To UBound(SayfaNumaralari)
        SayfaNumarasi = Val(SayfaNumaralari(i))
        SayfaAdi = ActiveWorkbook.Sheets(SayfaNumarasi).Name
        YeniDosyaAdi = YeniKlasor & "\" & SayfaAdi & ".xlsx"
        ActiveWorkbook.Sheets(SayfaNumarasi).Copy
        ActiveWorkbook.SaveAs Filename:=YeniDosyaAdi, FileFormat:=xlOpenXMLWorkbook
        ActiveWorkbook.Close False
    Next i

End Sub

Sub ArşivKlasörüOluştur()

Dim DosyaYolu As String
Dim KlasörAdı As String

DosyaYolu = ActiveWorkbook.Path
KlasörAdı = "ARŞİV"

'İşletim sistemi kontrolü
If InStr(1, Application.OperatingSystem, "Windows") > 0 Then
'Windows işletim sistemi için
MkDir DosyaYolu & "\" & KlasörAdı
ElseIf InStr(1, Application.OperatingSystem, "Mac") > 0 Then
'macOS işletim sistemi için
MkDir DosyaYolu & "/" & KlasörAdı
Else
'Diğer işletim sistemleri için hata mesajı ver
MsgBox "Bu işletim sistemi desteklenmiyor."
Exit Sub
End If

End Sub

MkDir DosyaYolu & "/" & KlasörAdı hocam bu satırda hata verioyr

RBozkurt · 12 Mart 2023

doganayfidaan' Alıntı:
MkDir DosyaYolu & "/" & KlasörAdı hocam bu satırda hata verioyr

ARŞİV klasörünü sabitleyerek; 8. mesajdaki çözüm olsun

doganayfidaan · 12 Mart 2023

RBozkurt' Alıntı:

Deneyiniz,
Bulunduğu dizinde ARŞİV klasörüne kayıt yapması gerekir.

Kod:

Sub AyirSayfalar()

    Dim DosyaAdi As String
    Dim DosyaYolu As String
    Dim YeniKlasor As String

    DosyaAdi = ActiveWorkbook.Name
    DosyaYolu = ActiveWorkbook.Path

    YeniKlasor = DosyaYolu & "\ARŞİV"

    Dim SayfaListesi As String
    Dim i As Integer

    SayfaListesi = "Lütfen kaydedilecek sayfaların numaralarını virgülle ayırarak girin:" & vbCrLf & vbCrLf
    For i = 1 To ActiveWorkbook.Sheets.Count
        SayfaListesi = SayfaListesi & i & " - " & ActiveWorkbook.Sheets(i).Name & vbCrLf
    Next i

    Dim KaydedilecekSayfalar As Variant
    KaydedilecekSayfalar = InputBox(SayfaListesi, "Sayfaları Ayır", "")

    Dim SayfaNumaralari As Variant
    SayfaNumaralari = Split(KaydedilecekSayfalar, ",")

    Dim SayfaNumarasi As Integer
    Dim SayfaAdi As String
    Dim YeniDosyaAdi As String

    For i = LBound(SayfaNumaralari) To UBound(SayfaNumaralari)
        SayfaNumarasi = Val(SayfaNumaralari(i))
        SayfaAdi = ActiveWorkbook.Sheets(SayfaNumarasi).Name
        YeniDosyaAdi = YeniKlasor & "\" & SayfaAdi & ".xlsx"
        ActiveWorkbook.Sheets(SayfaNumarasi).Copy
        ActiveWorkbook.SaveAs Filename:=YeniDosyaAdi, FileFormat:=xlOpenXMLWorkbook
        ActiveWorkbook.Close False
    Next i

End Sub

hocam bundada sayfalar kaydelimedi hatası veriyor.Cihazım yurtdışı cihaz bundan kaynaklı bi sorun olabilir mi yazım
karakter sorunu

hata satırı :
ActiveWorkbook.Sheets(SayfaNumarasi).Copy

RBozkurt · 12 Mart 2023

Macos için yorum yapamıyorum hocam

doganayfidaan · 12 Mart 2023

tamamdır hocam sağ olun macos için bilen biri yardımcı olabilir mi?

doganayfidaan · 12 Mart 2023

RBozkurt' Alıntı:

Deneyiniz,
Bulunduğu dizinde ARŞİV klasörüne kayıt yapması gerekir.

Kod:

Sub AyirSayfalar()

    Dim DosyaAdi As String
    Dim DosyaYolu As String
    Dim YeniKlasor As String
 
    DosyaAdi = ActiveWorkbook.Name
    DosyaYolu = ActiveWorkbook.Path
 
    YeniKlasor = DosyaYolu & "\ARŞİV"
 
    Dim SayfaListesi As String
    Dim i As Integer
 
    SayfaListesi = "Lütfen kaydedilecek sayfaların numaralarını virgülle ayırarak girin:" & vbCrLf & vbCrLf
    For i = 1 To ActiveWorkbook.Sheets.Count
        SayfaListesi = SayfaListesi & i & " - " & ActiveWorkbook.Sheets(i).Name & vbCrLf
    Next i
 
    Dim KaydedilecekSayfalar As Variant
    KaydedilecekSayfalar = InputBox(SayfaListesi, "Sayfaları Ayır", "")
 
    Dim SayfaNumaralari As Variant
    SayfaNumaralari = Split(KaydedilecekSayfalar, ",")
 
    Dim SayfaNumarasi As Integer
    Dim SayfaAdi As String
    Dim YeniDosyaAdi As String
 
    For i = LBound(SayfaNumaralari) To UBound(SayfaNumaralari)
        SayfaNumarasi = Val(SayfaNumaralari(i))
        SayfaAdi = ActiveWorkbook.Sheets(SayfaNumarasi).Name
        YeniDosyaAdi = YeniKlasor & "\" & SayfaAdi & ".xlsx"
        ActiveWorkbook.Sheets(SayfaNumarasi).Copy
        ActiveWorkbook.SaveAs Filename:=YeniDosyaAdi, FileFormat:=xlOpenXMLWorkbook
        ActiveWorkbook.Close False
    Next i
 
End Sub

Hocam tekrardan merhaba bu çalıştırdığımızda çıkan listede sadece 41 adet sayfa gözüküyor sayıları yazmaya devam edince bi sorun yok kaydediyor fakat liste sadece 41 sayfayı alıyor bunu list gibi aşağı doğru kaydırcak bir şekilde düzeltemezmiyiz. Windows için konuşuyorum.

RBozkurt · 12 Mart 2023

Malesef bu konuda çözüm bulamadım.

doganayfidaan · 12 Mart 2023

RBozkurt' Alıntı:
Malesef bu konuda çözüm bulamadım.

olsun hocam verdiğiniz bilgi bile yeter sağ olun .

doganayfidaan · 14 Mart 2023

+Guncel

RBozkurt · 15 Mart 2023

doganayfidaan' Alıntı:
+Guncel

C#:

Sub Kaydet()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim strFileName As String
    Dim strFolderName As String
    Dim strDate As String
    Dim i As Integer
    
    strFolderName = ThisWorkbook.Path & "\YEDEK\"
    
    If Dir(strFolderName, vbDirectory) = "" Then
        MkDir strFolderName
    End If
    
    strDate = Format(Date, "dd.mm.yyyy")
    
    Set wb = ThisWorkbook
    
    For i = 5 To wb.Worksheets.Count
        Set ws = wb.Worksheets(i)
        strFileName = strFolderName & ws.Name & "-" & strDate & ".xlsx"
        ws.Copy
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=strFileName, FileFormat:=51
        ActiveWorkbook.Close
        Application.DisplayAlerts = True
    Next i
    
End Sub

Bir dosyadakı sayfaları ayrı ayrı excel dosyalarına kaydettirme.

doganayfidaan

RBozkurt

𐱅𐰇𐰼𐰚

RBozkurt

𐱅𐰇𐰼𐰚

doganayfidaan

RBozkurt

𐱅𐰇𐰼𐰚

doganayfidaan

doganayfidaan

RBozkurt

𐱅𐰇𐰼𐰚

RBozkurt

𐱅𐰇𐰼𐰚

doganayfidaan

doganayfidaan

RBozkurt

𐱅𐰇𐰼𐰚

doganayfidaan

RBozkurt

𐱅𐰇𐰼𐰚

doganayfidaan

doganayfidaan

RBozkurt

𐱅𐰇𐰼𐰚

doganayfidaan

doganayfidaan

RBozkurt

𐱅𐰇𐰼𐰚