istenilen yerin kopyalanması

[meda58]

Sub KOPYALAMA()



Sheets("Sayfa1").Range("A1:E75").Copy

Dim sh As Worksheet

For Each sh In Worksheets



Select Case sh.Name

Case "Sayfa3", "Sayfa4", "Sayfa5"

Case Else



sh.Range("A1:E75").PasteSpecial



End Select

Next



Application.CutCopyMode = False

MsgBox "Kopyalama Yapıldı..!!"

End Sub





Sheets("Sayfa1").Range("A1:E75").Copy
arkadaşlar yukarıdaki makroda Sayfa1 de A1:E75 arası hariç tutulan sayfalar haricinde diğer sayfalara kopyalanıyor
bu makroyu istediğimiz sayfada istediğimiz yerleri seçerek kopyalama haline getirebilirmiyiz
şeçmeden bize uyarı verecek "KOPYALAMAK İSTEDİĞİNİZ BÖLGEYİ ŞEÇİNİZ"



sh.Range("A1:E75").PasteSpecial
Yapıştırmak istenilen bölgeyi veya hücreyi de aynı şekilde biz seçeceğiz

"YAPIŞTIRMAK İSTEDİĞİNİZ HÜCREYİ BELİRTİNİZ"

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Copy_Paste()
    Dim Copy_Area As Range, Paste_Area As Range, My_Sheet As Worksheet
  
    On Error Resume Next
    Set Copy_Area = Application.InputBox(Title:="Lütfen kopyalamak istediğiniz alanı seçiniz..", Prompt:="Hücre Seçimi", Type:=8)
    On Error GoTo 0

    If Copy_Area Is Nothing Then Exit Sub

    On Error Resume Next
    Set Paste_Area = Application.InputBox(Title:="Lütfen yapıştırmak istediğiniz alanı seçiniz..", Prompt:="Hücre Seçimi", Type:=8)
    On Error GoTo 0

    If Paste_Area Is Nothing Then Exit Sub
    
    For Each My_Sheet In ThisWorkbook.Worksheets
        Select Case My_Sheet.Name
            Case "Sayfa3", "Sayfa4", "Sayfa5"
            Case Else
            My_Sheet.Unprotect "Koruma Parolasını Buraya Yazınız"
            Copy_Area.Copy My_Sheet.Range(Paste_Area.Address)
            My_Sheet.Protect "Koruma Parolasını Buraya Yazınız"
        End Select
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[meda58]

Deneyiniz.

Option Explicit

Sub Copy_Paste()
    Dim Copy_Area As Range, Paste_Area As Range
 
    On Error Resume Next
    Set Copy_Area = Application.InputBox(Title:="Lütfen kopyalamak istediğiniz alanı seçiniz..", Prompt:="Hücre Seçimi", Type:=8)
    On Error GoTo 0

    If Copy_Area Is Nothing Then Exit Sub

    On Error Resume Next
    Set Paste_Area = Application.InputBox(Title:="Lütfen yapıştırmak istediğiniz alanı seçiniz..", Prompt:="Hücre Seçimi", Type:=8)
    On Error GoTo 0

    If Paste_Area Is Nothing Then Exit Sub
   
    Copy_Area.Copy Paste_Area
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

çok güzel çalışıyor yalnız ben bunu kitapta tüm sayfalara otomatik olarak yapmak istiyorum
örneğin 70 sayfa kitabım var bunlardan bazılarını hariç tutarak tek şeçimle tüm kopyalama işlemini tek seferde yapmak istiyorum
aşağıda belirtiğim kodda kalın yazıda belirtilen yerleri her seferinde değiştirmek istemiyorum birtek bunlar değişken olacak olacak


Sub KOPYALAMA()
Sheets("Sayfa1").Range("A1:E75").Copy
Dim sh As Worksheet
For Each sh In Worksheets
Select Case sh.Name
Case "Sayfa3", "Sayfa4", "Sayfa5"
Case Else
sh.Range("A1:E75").PasteSpecial
End Select
Next
Application.CutCopyMode = False
MsgBox "Kopyalama Yapıldı..!!"
End Sub

 

[Korhan Ayhan]

Kodu revize ettim. Tekrar deneyiniz.

 

[meda58]

Kodu revize ettim. Tekrar deneyiniz.

hocam önünüzde saygı ile eğiliyorum harikasınız mükemmel çalışıyor

ve utanarak bir şey daha istiyorum bu kodu korumalı sayfalarda işlem yapabilir hale getirebilirmisiniz
yalnız koruma devam edecek

 

[Korhan Ayhan]

Kodu tekrar revize ettim. Deneyiniz.

 

[meda58]

Kodu tekrar revize ettim. Deneyiniz.

hocam harikasınız hatta mükemmelsiniz