• DİKKAT

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

sayfa kopyalama

O

ordulu82

Altın Üye
Katılım
24 Mart 2006
Mesajlar
215
Arkadaşlar benim ricam kitap1 dosyasındaki sayfaları isimlerine göre kitap2 dosyasına kopyalamak. yardımlarını bekliyorum.
 

Ekli dosyalar

Merhaba,
Aşağıdaki kodu bir modüle yapıştırıp dener misiniz?
Kod: 
Sub Kopyala()
Application.ScreenUpdating = False
Workbooks.Open ThisWorkbook.Path & "\" & "Kitap2.xlsx"
 For i = 1 To Workbooks("Kitap1.xlsm").Sheets.Count
    Workbooks("Kitap1.xlsm").Sheets(Workbooks("Kitap1.xlsm").Sheets(i).Name).Copy _
    Before:=Workbooks("Kitap2.xlsx").Sheets("Sayfa1")
Next
Application.ScreenUpdating = True
Sheets(1).Select
MsgBox "İşlem Tamam...", vbInformation, "dEdE Başarılar Diler..."
End Sub
 
dEdE' Alıntı:
Merhaba,
Aşağıdaki kodu bir modüle yapıştırıp dener misiniz?
Kod: 
Sub Kopyala()
Application.ScreenUpdating = False
Workbooks.Open ThisWorkbook.Path & "\" & "Kitap2.xlsx"
 For i = 1 To Workbooks("Kitap1.xlsm").Sheets.Count
    Workbooks("Kitap1.xlsm").Sheets(Workbooks("Kitap1.xlsm").Sheets(i).Name).Copy _
    Before:=Workbooks("Kitap2.xlsx").Sheets("Sayfa1")
Next
Application.ScreenUpdating = True
Sheets(1).Select
MsgBox "İşlem Tamam...", vbInformation, "dEdE Başarılar Diler..."
End Sub
Genişletmek için tıkla ...
Üstadım olmadı. makro hata veriyor, direk kitap2 açılıyor ama sayfalar aynı
 
Merhaba,
Ekli dosya yukarıdaki kodlarla istediğiniz işlemi yapmaktadır.
Kitap1 isimli dosyanız makro etkin çalışma kitabı (.xlsm) olarak kaydedilmelidir. Profilinizde kullandığınız ecxel versiyonu yazmıyor, eklediğiniz dosyadan office 97 veya üstü kullandığınızı varsayarak kodu ona göre yazdım.
 

Ekli dosyalar

dEdE' Alıntı:
Merhaba,
Ekli dosya yukarıdaki kodlarla istediğiniz işlemi yapmaktadır.
Kitap1 isimli dosyanız makro etkin çalışma kitabı (.xlsm) olarak kaydedilmelidir. Profilinizde kullandığınız ecxel versiyonu yazmıyor, eklediğiniz dosyadan office 97 veya üstü kullandığınızı varsayarak kodu ona göre yazdım.
Genişletmek için tıkla ...
Üstadım teşekkür ederim şimdi sayfaları aktardı.Ama benim istediğim sadece aktif sayfanın aktarılması. bu kod tüm kitabı aktarıyor.Aslında benim çalışma dosyamı size anlatırsam daha açıklayıcı olacak. Benim hesaplama yaptığm bir sayfam var. ilgili ayın işlemleri bitince bu kod sayesinde o ayın sayfasını arşiv adlı bir çalışma kitabına kopyalamak. bir sonraki ayda da yine aynı sayfayı ismini değiştirerek kullanıyorum. yani daha önce ocak yazan sayfanın adını şubat olarak değiştirip tekrar hesaplama yapıyorum. Bu arada office sürümüm 2007
 
ordulu82' Alıntı:
Arkadaşlar benim ricam kitap1 dosyasındaki sayfaları isimlerine göre kitap2 dosyasına kopyalamak. yardımlarını bekliyorum.
Genişletmek için tıkla ...
Merhaba,
İlk mesajınızda "sayfaları" diyerek birden fazla sayfa kopyalanacağını belirtmişsiniz. Aktif sayfa deseydiniz ona göre yazardık kodu.
Neyse, aşağıdaki kodu yukarıda belirttiğim koşullarda çalıştırırsanız istediğinizi yapar.
Kod: 
Sub Kopyala()
    Application.ScreenUpdating = False
    Workbooks.Open ThisWorkbook.Path & "\" & "Kitap2.xlsx"
    Workbooks("Kitap1.xlsm").ActiveSheet.Copy Before:=Workbooks("Kitap2.xlsx").Sheets("Sayfa1")
    Application.ScreenUpdating = True
    Sheets(1).Select
    MsgBox "İşlem Tamam...", vbInformation, "dEdE Başarılar Diler..."
End Sub
 
dEdE' Alıntı:
Merhaba,
İlk mesajınızda "sayfaları" diyerek birden fazla sayfa kopyalanacağını belirtmişsiniz. Aktif sayfa deseydiniz ona göre yazardık kodu.
Neyse, aşağıdaki kodu yukarıda belirttiğim koşullarda çalıştırırsanız istediğinizi yapar.
Kod: 
Sub Kopyala()
    Application.ScreenUpdating = False
    Workbooks.Open ThisWorkbook.Path & "\" & "Kitap2.xlsx"
    Workbooks("Kitap1.xlsm").ActiveSheet.Copy Before:=Workbooks("Kitap2.xlsx").Sheets("Sayfa1")
    Application.ScreenUpdating = True
    Sheets(1).Select
    MsgBox "İşlem Tamam...", vbInformation, "dEdE Başarılar Diler..."
End Sub
Genişletmek için tıkla ...
Üstad kod çalışmadı. :)
 
Merhaba,
Ekli dosyaya dener misiniz?
 

Ekli dosyalar

dEdE' Alıntı:
Merhaba,
Ekli dosyaya dener misiniz?
Genişletmek için tıkla ...
Üstad bu defa mükemmel çalışıyor. teşekkür ederim. Son olarak benim dosyalarımda formül olduğundan kopyalamayı kopyala-özel yapıştır-değerler şeklinde nasıl yapıcaz. formüllerin kopyalanmasını istemiyorum.
 
Merhaba,
İsteklerinizi en başta yazsanız forumda kirliliğe neden olmasak !!! :(
Kodu aşağıdaki ile değiştirin.
Kod: 
Sub Kopyala()
    Application.ScreenUpdating = False
    Workbooks.Open ThisWorkbook.Path & "\" & "Kitap2.xlsx"
    Workbooks("Kitap1.xlsm").ActiveSheet.Copy Before:=Workbooks("Kitap2.xlsx").Sheets("Sayfa1")
    ActiveSheet.Cells.Copy
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
    Sheets(1).Select
    [A1].Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam...", vbInformation, "dEdE Başarılar Diler..."
End Sub
 
dEdE' Alıntı:
Merhaba,
İsteklerinizi en başta yazsanız forumda kirliliğe neden olmasak !!! :(
Kodu aşağıdaki ile değiştirin.
Kod: 
Sub Kopyala()
    Application.ScreenUpdating = False
    Workbooks.Open ThisWorkbook.Path & "\" & "Kitap2.xlsx"
    Workbooks("Kitap1.xlsm").ActiveSheet.Copy Before:=Workbooks("Kitap2.xlsx").Sheets("Sayfa1")
    ActiveSheet.Cells.Copy
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
    Sheets(1).Select
    [A1].Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam...", vbInformation, "dEdE Başarılar Diler..."
End Sub
Genişletmek için tıkla ...
Üstadım mükemmel olmuş. Teşekkür ederim eline sağlık
 
Üstadım dosyaları başka bir klasöre almak istiyorum bunu nasıl yapabilrim.
mesela c sürücüsü bordro klasörünün içine :)
 
ordulu82' Alıntı:
Üstadım dosyaları başka bir klasöre almak istiyorum bunu nasıl yapabilrim. mesela c sürücüsü bordro klasörünün içine :)
Genişletmek için tıkla ...
Merhaba,
Kaynak ve hedef klasörünüz aynı olmak koşulu ile yukarıdaki kod her klasörde çalışır.
Dosyaları kod yardımıyla başka bir klasöre almak(taşımak/kopyalamak) istiyorsanız forumda örnekleri var.Arama yaparsanız bulursunuz.
 
Son düzenleme:
dEdE' Alıntı:
Merhaba,
Kaynak ve hedef klasörünüz aynı olmak koşulu ile yukarıdaki kod her klasörde çalışır.
Dosyaları kod yardımıyla başka bir klasöre almak(taşımak/kopyalamak) istiyorsanız forumda örnekleri var.Arama yaparsanız bulursunuz.
Genişletmek için tıkla ...

dEdE Üstadım kusura bakmayın bir rica daha olucak. ben sayfa kopyalama yaparken mesela ocak ayını kopyalarken ilgili dosyada ocak adı bir sayfa daha varsa ilgili dosyayı değiştirmek istiyormusunuz şeklinde bir uyarı penceresi çıkabilir mi ?
 
Merhaba,
Aşağıdaki kodu kullanabilirsiniz.
Kod: 
Sub Kopyala()
    sAdı = ThisWorkbook.ActiveSheet.Name
    Application.ScreenUpdating = False
    Workbooks.Open ThisWorkbook.Path & "\" & "Kitap2.xlsx"
    
    For i = 1 To Sheets.Count
        If Sheets(i).Name = sAdı Then
            If MsgBox(Sheets(i).Name & " İsimli Sayfa Var." & vbCrLf & " Yine de Aktarmak İstiyor musunuz?", _
            vbYesNo + vbQuestion, "U Y A R I   !!!!") = vbNo Then Exit Sub
        End If
    Next
    
    Workbooks("Kitap1.xlsm").ActiveSheet.Copy Before:=Workbooks("Kitap2.xlsx").Sheets("Sayfa1")
    ActiveSheet.Cells.Copy
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
    Sheets(1).Select
    [A1].Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam...", vbInformation, "dEdE Başarılar Diler..."
End Sub
 
dEdE' Alıntı:
Merhaba,
Aşağıdaki kodu kullanabilirsiniz.
Kod: 
Sub Kopyala()
    sAdı = ThisWorkbook.ActiveSheet.Name
    Application.ScreenUpdating = False
    Workbooks.Open ThisWorkbook.Path & "\" & "Kitap2.xlsx"
    
    For i = 1 To Sheets.Count
        If Sheets(i).Name = sAdı Then
            If MsgBox(Sheets(i).Name & " İsimli Sayfa Var." & vbCrLf & " Yine de Aktarmak İstiyor musunuz?", _
            vbYesNo + vbQuestion, "U Y A R I   !!!!") = vbNo Then Exit Sub
        End If
    Next
    
    Workbooks("Kitap1.xlsm").ActiveSheet.Copy Before:=Workbooks("Kitap2.xlsx").Sheets("Sayfa1")
    ActiveSheet.Cells.Copy
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
    Sheets(1).Select
    [A1].Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam...", vbInformation, "dEdE Başarılar Diler..."
End Sub
Genişletmek için tıkla ...

dEdE üstadım yine kızıcaksınız ama sanırım yine eksik söyledim. uyarı gelicek ama sayfayı da değiştiricek. yani devam etmek istiyormusunuz sorusuna evet dediğimde sayfayı değiştirsin
 
Merhaba,
Aşağıdaki kodu dener misiniz?
Kod: 
Sub Kopyala()
    sAdı = ThisWorkbook.ActiveSheet.Name
    Application.ScreenUpdating = False
    Workbooks.Open ThisWorkbook.Path & "\" & "Kitap2.xlsx"
    For i = 1 To Sheets.Count
        If Sheets(i).Name = sAdı Then
            If MsgBox(Sheets(i).Name & "  İsimli Sayfa Var." & vbCrLf & " Yine de Aktarmak İstiyor musunuz?", _
            vbYesNo + vbQuestion, "U Y A R I   !!!!") = vbNo Then Exit Sub
            Windows("Kitap1.xlsm").Activate
            ActiveSheet.UsedRange.Copy
            Windows("Kitap2.xlsx").Activate
            Sheets(i).[A1].Select
            ActiveSheet.Paste
            GoTo Atla
        End If
    Next
    Workbooks("Kitap1.xlsm").ActiveSheet.Copy Before:=Workbooks("Kitap2.xlsx").Sheets(1)
Atla:
    ActiveSheet.Cells.Copy
    ActiveSheet.Cells.PasteSpecial xlPasteValues
    [A1].Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam...", vbInformation, "dEdE Başarılar Diler..."
End Sub
 
dEdE' Alıntı:
Merhaba,
Aşağıdaki kodu dener misiniz?
Kod: 
Sub Kopyala()
    sAdı = ThisWorkbook.ActiveSheet.Name
    Application.ScreenUpdating = False
    Workbooks.Open ThisWorkbook.Path & "\" & "Kitap2.xlsx"
    For i = 1 To Sheets.Count
        If Sheets(i).Name = sAdı Then
            If MsgBox(Sheets(i).Name & "  İsimli Sayfa Var." & vbCrLf & " Yine de Aktarmak İstiyor musunuz?", _
            vbYesNo + vbQuestion, "U Y A R I   !!!!") = vbNo Then Exit Sub
            Windows("Kitap1.xlsm").Activate
            ActiveSheet.UsedRange.Copy
            Windows("Kitap2.xlsx").Activate
            Sheets(i).[A1].Select
            ActiveSheet.Paste
            GoTo Atla
        End If
    Next
    Workbooks("Kitap1.xlsm").ActiveSheet.Copy Before:=Workbooks("Kitap2.xlsx").Sheets(1)
Atla:
    ActiveSheet.Cells.Copy
    ActiveSheet.Cells.PasteSpecial xlPasteValues
    [A1].Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam...", vbInformation, "dEdE Başarılar Diler..."
End Sub
Genişletmek için tıkla ...
Üstadım eline sağlık tam istediğim gibi olmuş. Çok teşekkür ederim..
 
ordulu82' Alıntı:
Üstadım eline sağlık tam istediğim gibi olmuş. Çok teşekkür ederim..
Genişletmek için tıkla ...

Merhabalar Üstadım
Geçen yazmış olduğunuz kodda ufak bir sorun oluştu. dosyayı kullandıkça sorunları anlayabiliyoruz. Sayfayı ilk defa kopyalarken sorun yok tam istediğim şekilde yani sadece değerleri kopyalıyor. fakat hedef sayfada aynı isimli bir sayfa varsa formülleri de kopyalamaya çalışıyor, ayrıca sayfanın tamamını değilde mesela kopyalamaya b2 den başlıyor. bu defa da veriler üst üste geliyor. ben dosyayı sisteme ekledim rica etsem bi bakabilirmisniz. mümkünse eski sayfayı tamamen silip yerine yeni sayfası eklerse daha sağlıklı olur
yardımcı olabilirseniz çok sevinirim.
 

Ekli dosyalar

Merhaba,
Mevcut kodlarınızda aşağıda belirttiğim satırların arasına kırmızı ile işaretlediğim satırı ekleyip dener misiniz?
Kod: 
vbYesNo + vbQuestion, "U Y A R I   !!!!") = vbNo Then Exit Sub
[COLOR="Red"] Sheets(i).UsedRange.Clear[/COLOR]            
Windows("Kitap1.xlsm").Activate
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst