• DİKKAT

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

Açık kitapları alt alta topla

A

ADER_34

Katılım
2 Haziran 2015
Mesajlar
349
Excel Vers. ve Dili
2010
Selam hayırlı akşamlar, sizden bi konuda yrdım istiyicem aktif olarak 2 tane açık çalışma kitabım var bazen webden 3 adet sayfa isimleri değişken xls uzantılı excel çalışma kitabı istiyorum ve sütun sayıları,başlıklar hep standart ben 2 adet çalışma sayfam hariç diger 3 ad çalışma sayfasındaki tüm dolu satırları yeni bir çalışma sayfası açarak alt alta yapıştırmak istiyorum mümkünmü örnek doyam ekte kolay gelsin teşekkürler...
NOT: aktif çalışma kitapları adı "1" "LİSTE" "2" çalışma kitabı "DEPO" adlı kitaplar hariç tutulacak bunlar klasör içinde aktif "3" tane çalışma kitapları klasör dışında oluyor..

http://s6.dosya.tc/server7/ukpxn5/ALT_ALTA_TOLA.rar.html
 
Aşağıdaki kodu deneyiniz.

Kod: 
Sub Verileri_Aktar()
    Dim Kitap As Workbook, K1 As Workbook, Satir As Long
    
    Satir = 1
    
    For Each Kitap In Application.Workbooks
        Select Case Kitap.Name
            Case "DEPO.xlsx", "LİSTE.xlsx", "DEPO.xlsm", "LİSTE.xlsm"
            Case Else
                If K1 Is Nothing Then Set K1 = Workbooks.Add(1)
                Kitap.Sheets(1).Range("A1").CurrentRegion.Copy K1.Sheets(1).Cells(Satir, 1)
                If Satir <> 1 Then K1.Sheets(1).Cells(Satir, 1).EntireRow.Delete
                Satir = K1.Sheets(1).Cells(K1.Sheets(1).Rows.Count, 1).End(3).Row + 1
        End Select
    Next
End Sub
 
Merhab Korhan bey kodlarınızı denedim yeni çalışma sayfası açıyor fakat verleri kopyalamıyor, hariç tutulması gereken sayfalar uzantısı "xlsx" fakat diğer 3 ad çalışma sayfası uzantısı "xls" bundan olabilirmi? yada hiç açmıyor olabilir mi? sonuç olarak yeni açılan excel çalışma kitabı var ama içi boş bakabilirmisiniz teşekkürler..
 
Kodun çalışması için bahsi geçen tüm dosyaların açık olması gerekiyor.
 
Haklısınız Korhan Bey kodlarınız sorunsuz çalışıyor çok teşekkür ederim,peki yeni çalışma kitabı yerine verileri istediğim hedef bir çalışma kitabının sayfasına taşıyabilmem için kodlarda ne gibi bir değişiklik yapmam gerekiyor kolay gelsin...
 
Aşağıdaki kodu deneyiniz.

Kırmızı bölümü istediğiniz gibi değiştirip deneyiniz.

Kod: 
Sub Verileri_Aktar()
    Dim Kitap As Workbook, K1 As Workbook, Satir As Long, Dosya As String
    
    [COLOR="Red"]Dosya = ThisWorkbook.Path & "\Yedek.xlsx"[/COLOR]

    Set K1 = Workbooks.Open(Dosya, False, False)
    
    Satir = 1
    
    For Each Kitap In Application.Workbooks
        Select Case Kitap.Name
            Case "DEPO.xlsx", "LİSTE.xlsx", "DEPO.xlsm", "LİSTE.xlsm"
            Case Else
                Kitap.Sheets(1).Range("A1").CurrentRegion.Copy K1.Sheets(1).Cells(Satir, 1)
                If Satir <> 1 Then K1.Sheets(1).Cells(Satir, 1).EntireRow.Delete
                Satir = K1.Sheets(1).Cells(K1.Sheets(1).Rows.Count, 1).End(3).Row + 1
        End Select
    Next
End Sub
 
Merhaba Korhan Bey malesef bu kodda hata aldım,""Set K1 = Workbooks.Open(Dosya, False, False)
çalışma sayfa adını kendi dosyamla değiştirdim sepeb nedir acaba kolay gelsin teşekkürler...
 
Sizin dosyanızdaki durum nedir bilemiyorum. Ben denedim ve olumlu sonuç aldım. Daha sonrada kodu foruma ekledim.

Alternatif aşağıdaki kodu deneyin.

Bu kodda dosyaların açık olmasına gerek yok. Bir üst klasördeki dosyaları kontrol ediyor.

Kod: 
Sub Verileri_Aktar()
    Dim Klasor As String, Kitap As String
    Dim K1 As Workbook, K2 As Workbook
    Dim Satir As Long, Dosya As String
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dosya = ThisWorkbook.Path & "\Yedek.xlsx"
    Set K1 = Workbooks.Open(Dosya, False, False)
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Klasor = FSO.GetFolder(ThisWorkbook.Path).ParentFolder.Path
    
    Satir = 1
    
    Kitap = Dir(Klasor & "\*.xl*")
            
    Do
        Select Case Kitap
            Case "Yedek.xlsx", "DEPO.xlsx", "LİSTE.xlsx", "DEPO.xlsm", "LİSTE.xlsm"
            Case Else
                Set K2 = Workbooks.Open(Klasor & "\" & Kitap, False, False)
                K2.Sheets(1).Range("A1").CurrentRegion.Copy K1.Sheets(1).Cells(Satir, 1)
                If Satir <> 1 Then K1.Sheets(1).Cells(Satir, 1).EntireRow.Delete
                Satir = K1.Sheets(1).Cells(K1.Sheets(1).Rows.Count, 1).End(3).Row + 1
                K2.Close 0
        End Select
        Kitap = Dir
    Loop While Kitap <> ""
    
    K1.Save
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan Bey yine aynı satırda hata verdi hata açıklaması şöyle "ne yazık ki yedek.xlsx dosyasını bulamadık..dosya taşınmış yada silinmiş olabilir ama dosya adı yedek.xlsx olarak orda duruyor
 
Uyguladığınız dosyalarınızı ekleyin deneyelim.
 
Aşağıdaki gibi deneyiniz.

Kodu DEPO ve LİSTE dosyalarınızın olduğu klasördeki bir dosyaya uygulayınız. Aksi halde sonuç vermez.

Kod: 
Sub Verileri_Aktar()
    Dim Klasor As String, Kitap As String
    Dim K1 As Workbook, K2 As Workbook
    Dim Satir As Long, Dosya As String
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Klasor = FSO.GetFolder(ThisWorkbook.Path).ParentFolder.Path
    
    Dosya = Klasor & "\Yedek.xlsx"
    Set K1 = Workbooks.Open(Dosya, False, False)
    
    Satir = 1
    
    Kitap = Dir(Klasor & "\*.xl*")
            
    Do
        Select Case Kitap
            Case "Yedek.xlsx", "DEPO.xlsx", "LİSTE.xlsx", "DEPO.xlsm", "LİSTE.xlsm"
            Case Else
                Set K2 = Workbooks.Open(Klasor & "\" & Kitap, False, False)
                K2.Sheets(1).Range("A1").CurrentRegion.Copy K1.Sheets(1).Cells(Satir, 1)
                If Satir <> 1 Then K1.Sheets(1).Cells(Satir, 1).EntireRow.Delete
                Satir = K1.Sheets(1).Cells(K1.Sheets(1).Rows.Count, 1).End(3).Row + 1
                K2.Close 0
        End Select
        Kitap = Dir
    Loop While Kitap <> ""
    
    K1.Close 1
    ThisWorkbook.Close 0
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Merhaba Korhan Bey kodlarınızı denedim dediğinizi yaptım, ama yine aynı kodda hata aldım
Set K1 = Workbooks.Open(Dosya, False, False) bu satırda duruyor, dediğim gibi ilk yazdığınız kodu şuan kullanıyorum tek isteğim 2 açık çalışma kitabı hariç diğer açık kitapları kapatması kolay gelsin teşekkürler..
 
Merhaba Korhan Bey sonuç yine aynı,Set K1 = Workbooks.Open(Dosya, False, False) bu kodda hata veriyor..yani tek isteğim ilk yazdığınız kod çok başarılı bu koda ilave kod olarak hangi kodu eklersem "LİSTE" VE "DEPO" dosyaları hariç diğer açık excel dosyalarını kapatırım kolay gelsin teşekkürler..
 
Bende çalışan makro sizde neden sonuç vermedi açıkçası merak ettim.

Uygunsanız bilgisayarınıza uzak bağlantı yapıp kontrol etmek isterim.

TeamViewer programı bağlantı id ve şifresini özelden gönderebilirsiniz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst