• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

sayfaları ayrı kaydederken sayfa yapısı bozuluyor.

E

euphrates55

Katılım
25 Ocak 2006
Mesajlar
763
Excel Vers. ve Dili
2019 tr
Kod: 
Sub sayfalari_ayir_kaydet()
    Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
    MyFilePath$ = ActiveWorkbook.Path & "\" & _
    Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
         On Error Resume Next
        MkDir MyFilePath
        For N = 1 To Sheets.Count
            Sheets(N).Activate
            SheetName = ActiveSheet.Name
            Cells.Copy
            Workbooks.Add (xlWBATWorksheet)
            With ActiveWorkbook
                With .ActiveSheet
                    .Paste
                    .Name = SheetName
                    [A1].Select
                End With
                  
                .SaveAs Filename:=MyFilePath _
                & "\" & [c4].Value & ".xlsx" 'ismini almasını istediğin hücreyi burada değiş (c4)
                .Close SaveChanges:=True
            End With
            .CutCopyMode = False
        Next
    End With
    Sayfa1.Activate
End Sub

bu kodu uyguladığımda sayfa yapısı bozularak dışarıya çıkartıyor. sayfa yapısı aynı kalması için nereyi değiştirmeliyim.
 
Merhaba,
Sayfanın yapısının bozulmasını istemiyorsanız verileri değil sayfayı kopyalayınız.
Rich (BB code): 
Sub sayfalari_ayir_kaydet()
    Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
    MyFilePath$ = ActiveWorkbook.Path & "\" & _
    Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
         On Error Resume Next
        MkDir MyFilePath
        For N = 1 To Sheets.Count
            Sheets(N).Copy
            With ActiveWorkbook
                .SaveAs Filename:=MyFilePath _
                    & "\" & [c4].Value & ".xlsx" 'ismini almasını istediğin hücreyi burada değiş (c4)
                .Close SaveChanges:=True
            End With
        Next
    End With
    Sayfa1.Activate
End Sub
 
Rica ederim,
Bir de ilave olarak: Kodun baş tarafında devre dışı bıraktığınız ekran güncelleme ve uyarı gösterme işlemlerini aktif ederseniz dosyanız daha sağlıklı çalışacaktır. Sondaki End With satırından önce ekleyiniz.
Rich (BB code): 
    Next
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
İyi çalışmalar...
 
ÖmerBey' Alıntı:
Rica ederim,
Bir de ilave olarak: Kodun baş tarafında devre dışı bıraktığınız ekran güncelleme ve uyarı gösterme işlemlerini aktif ederseniz dosyanız daha sağlıklı çalışacaktır. Sondaki End With satırından önce ekleyiniz.
Rich (BB code): 
    Next
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
İyi çalışmalar...
Genişletmek için tıkla ...
evet o konuda sıkıntım var. yavaş yavaş mantık kurmaya başlıyorum vba ile ama kopya çekerek. yani hazır ya da benzerler üzerinden derleme toparlama yapmaya çalışıyorum. dolayısı ile kod olarak çalışan ama farkına varmadan beni zora sokan şeyler yapıyor olabilirim. bu vesile ile bir soru somak isterim. yeni konu açmadan cevap verme şansınız olursa sevinirim.

aşağıdaki kod excel dosyasındaki sayfaları birleştiriyor.
isteğim ise, ana dosyam hep aynı kalsın. bunun için de bu excelleri başka bir excel dosyasında ve kodu çalıştıracağım excelimin bulunduğu dizinde "FORMFRT-BİRLEŞTİRME" adlı excel dosyasında toplasın ve kaydedip kapasın
dolayısı ile ana dosyam hep aynı kalsın. olabilir mi? bir de yukarıda bahsettiğiniz gibi mantık hatası ya da tavsiyeniz varsa dinlemek isterim. bu kodu farklı farklı klasörler için çokca kullanıyorum çünkü.


Kod: 
Public bekle
Sub FORMFRTSERVİSbirleştirmeÜb()
bekle = "dur"

MsgBox "SERVİSLER KLASÖRÜNDEKİ FORMFRT KLASÖRÜNÜN İÇİNDEKİ üb KLASÖRÜ İÇİNDEKİ EXCELLERİ BİRLEŞTİRİR… ", vbExclamation, " UYARI!"
Secim = MsgBox("BU KLASÖRÜN VAR MI?", vbYesNo + vbCritical, "İYİ DÜŞÜN")
If Secim = vbYes Then
Application.Visible = True
ElseIf Secim = vbNo Then
MsgBox "PEKİ, İPTAL EDELİM O HALDE!", vbMsgBoxSetForeground
Exit Sub

End If

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Path = ThisWorkbook.Path & "\SERVİSLER\FORMFRT\üb\"
Filename = Dir(Path & "*.xlsx")
  Do While Filename <> ""
  Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
     For Each Sheet In ActiveWorkbook.Sheets
     ActiveSheet.Name = ActiveSheet.Range("v1")
     Sheet.Copy After:=ThisWorkbook.Sheets(1)
  Next Sheet
     Workbooks(Filename).Close
     Filename = Dir()
  Loop
bekle = ""
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Birleştirme Tamamlandı", vbInformation
End Sub
 
Merhaba,
Kodunuza kırmızı ilaveyi yaparak deneyiniz.
Rich (BB code): 
dosya = ThisWorkbook.Path & "\FORMFRT-BİRLEŞTİRME.xlsx"
If Dir(dosya) = "" Then 'Böyle bir dosya yoksa oluşturur
    Set w1 = Workbooks.Add
    w1.SaveAs Filename:=dosya, FileFormat:=xlOpenXMLWorkbook
Else
    Set w1 = Workbooks.Open(dosya) 'Dosya varsa var olan dosyayı açar
End If
Path = ThisWorkbook.Path & "\SERVİSLER\FORMFRT\üb\"
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
   For Each Sheet In ActiveWorkbook.Sheets
   ActiveSheet.Name = ActiveSheet.Range("v1")
   Sheet.Copy After:=w1.Sheets(1) 'Kopyalamayı diğer dosyaya yapar
Next Sheet
   Workbooks(Filename).Close
   Filename = Dir()
Loop
w1.Save 'Dosyayı kaydeder
w1.Close 'Dosyayı kapatır
 
Kod: 
End If
Dosya = ThisWorkbook.Path & "\FORMFRT-BİRLEŞTİRME.xlsx"
If Dir(Dosya) = "" Then 'Böyle bir dosya yoksa oluşturur
    Set w1 = Workbooks.Add
    w1.SaveAs Filename:=Dosya, FileFormat:=xlOpenXMLWorkbook
Else
    Set w1 = Workbooks.Open(Dosya) 'Dosya varsa var olan dosyayı açar
End If

[ICODE]Dosya = ThisWorkbook.Path & "\FORMFRT-BİRLEŞTİRME.xlsx"[/ICODE]
Kısmı hata verdi. yanlış yere mi ekledim acaba
 
Kodunuzda dosya isminde başka bir tanımlama, prosedür, modül adı vs. varsa başka bir isim yapıp deneyiniz.
 
evet sebep oymuş. yalnız excel dosyası oluşturuyor olsa da kodu çalıştırdığım excelin içinde birleştirme yapıyor.
 
Sheet.Copy After:=ThisWorkbook.Sheets(1) kısmını Sheet.Copy After:=w1.Sheets(1) olarak değiştirdiniz mi?
 
değişmemiştim. değişince oldu :) son olarak; kodu 2.kere tekrar çalıştırdığımda aynı sayfaları 2. kere ekliyor. eski dosyayı silip yenisini oluştursa sanırım daha kullanışlı olacak. biraz daha ileri gidecek olursam eski dosyayı bir klasör içinde yedeklese süper olur. 2. biraz fantaziye kaçtı. uğraştırmayayım sizi. 1. yeterli. teşekkürler bu arada.
 
Şu şekilde düzenlerseniz dosya varsa siler ve yeni dosya oluşturur.
Kod: 
dosya = ThisWorkbook.Path & "\FORMFRT-BİRLEŞTİRME.xlsx"
If Dir(dosya) <> ""
    Kill dosya
End If
Set w1 = Workbooks.Add
w1.SaveAs Filename:=dosya, FileFormat:=xlOpenXMLWorkbook

Şu şekilde de her çalıştırdığınızda dosya adına tarih ve saat ekleyerek farklı bir dosya oluşturur. Arşivlemek için dosya yolunu(ThisWorkbook.Path) arşiv klasörünüzün yolu olarak değiştirebilirsiniz.
Kod: 
dosya = ThisWorkbook.Path & "\FORMFRT-BİRLEŞTİRME_" & Format(Now, "yyyymmdd_hhssnn") & ".xlsx"
Set w1 = Workbooks.Add
w1.SaveAs Filename:=dosya, FileFormat:=xlOpenXMLWorkbook
 
Kod: 
Dosyak = ThisWorkbook.Path & "\yedek\FORMFRT-BİRLEŞTİRME_" & Format(Now, "yyyymmdd_hhssnn") & ".xlsx"
Set w1 = Workbooks.Add
w1.SaveAs Filename:=Dosyak, FileFormat:=xlOpenXMLWorkbook


Dosyam = ThisWorkbook.Path & "\FORMFRT-BİRLEŞTİRME.xlsx"
If Dir(Dosyam) <> "" Then
    Kill Dosyam
End If
Set w2 = Workbooks.Add
w2.SaveAs Filename:=Dosyam, FileFormat:=xlOpenXMLWorkbook

:( birleştiremedim...
 
Bunlar iki farklı seçenek, birini tercih edip yapacaksınız.
12 numaralı mesajda verdiğim birinci kod ile eski dosyayı siler aynı dizine yeni dosya oluşturursunuz.
İkinci kodla da her çalıştırdığınızda ayrı bir dosya oluşmasını sağlarsınız.
 
ÖmerBey' Alıntı:
Bunlar iki farklı seçenek, birini tercih edip yapacaksınız.
12 numaralı mesajda verdiğim birinci kod ile eski dosyayı siler aynı dizine yeni dosya oluşturursunuz.
İkinci kodla da her çalıştırdığınızda ayrı bir dosya oluşmasını sağlarsınız.
Genişletmek için tıkla ...
teşekkürler. uyardığınız için... yoksa sabaha kadar bir sağa bir sola koyup dururdum :)
 
@ÖmerBey
Ömer Bey;
5. mesajdaki kod excelleri birleştirirken isime göre sıralıyor. koda değiştirilme tarihine göre (ilk eklenen ilk sırada olacak) birleştirme kodu eklenmesi gibi bir durum söz konusu olur mu? var mı öyle bir kod.
 
Buyurunuz.
PHP: 
Sub kod()
Dim x As Integer, a As Integer, b As Integer
Dim w1 As Workbook, w2 As Workbook, Sh As Worksheet
Dim dosyalar(), y
Dim dosya As String, Path As String, Filename As String
Dim ds As Object

dosya = ThisWorkbook.Path & "\FORMFRT-BİRLEŞTİRME_" & Format(Now, "yyyymmdd_hhssnn") & ".xlsx"
Set w1 = Workbooks.Add
w1.SaveAs Filename:=dosya, FileFormat:=xlOpenXMLWorkbook

Set ds = CreateObject("Scripting.FileSystemObject")
Path = ThisWorkbook.Path & "\SERVİSLER\FORMFRT\üb\"
Filename = Dir(Path & "*.xlsx")

'************Dosya isimlerini değişkene alma**************
'********Bunun yerine sayfaya da aldırabilirsiniz*********
Do While Filename <> ""
    ReDim Preserve dosyalar(1, x)
    dosyalar(0, x) = Path & Filename
    dosyalar(1, x) = ds.GetFile(Path & Filename).DateLastModified
    Filename = Dir()
    x = x + 1
Loop

'************Dosyaları tarihe göre sıralama**************
'*****Bunun yerine sayfada sıralama yapabilirsiniz*******
For a = LBound(dosyalar, 2) To UBound(dosyalar, 2) - 1
    For b = a + 1 To UBound(dosyalar, 2)
        If CDbl(dosyalar(1, a)) > CDbl(dosyalar(1, b)) Then 'Sıralamayı değiştirmek için < işareti
            y = dosyalar(1, b)
            dosyalar(1, b) = dosyalar(1, a)
            dosyalar(1, a) = y
            y = dosyalar(0, b)
            dosyalar(0, b) = dosyalar(0, a)
            dosyalar(0, a) = y
        End If
    Next
Next

'************Dosyaları tarih sırasına göre açma**************
For a = LBound(dosyalar, 2) To UBound(dosyalar, 2)
    Set w2 = Workbooks.Open(Filename:=dosyalar(0, a), ReadOnly:=True)
    For Each Sh In w2.Sheets
        Sh.Copy After:=w1.Sheets(1)
    Next Sh
    w2.Close 0
Next
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst