• DİKKAT

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

Düğme ile eklenen yeni sayfaya resim ekleme

A

ayemenici

Katılım
14 Şubat 2005
Mesajlar
137
herkese merhaba,
Arkadaşlar aşağıda verdiğim örnek dosyada komut düğmesi ile yeni sayfa ekliyorum ve toblo ve resim bulunan tutanak sayfasını da biçim ve değer olarak KOPYALATTIRIYORUM.
ancak tutanak sayfasında bulunan bayrak logosunu yeni eklenen sayfaya birtürlü ekletemedim.
(tutanak sayfasını komple kopyalandığında logo da geliyor ancak tutanak sayfasındaki formüllerde geliyor. formüllerin gelmesini istemiyorum.)
 

Ekli dosyalar

ayemenici' Alıntı:
herkese merhaba,
Arkadaşlar aşağıda verdiğim örnek dosyada komut düğmesi ile yeni sayfa ekliyorum ve toblo ve resim bulunan tutanak sayfasını da biçim ve değer olarak KOPYALATTIRIYORUM.
ancak tutanak sayfasında bulunan bayrak logosunu yeni eklenen sayfaya birtürlü ekletemedim.
(tutanak sayfasını komple kopyalandığında logo da geliyor ancak tutanak sayfasındaki formüllerde geliyor. formüllerin gelmesini istemiyorum.)
Genişletmek için tıkla ...

bu işinizi görürmü


Sub kopyala()
deg = 0
Worksheets("veri").Range("C20").NumberFormat = "@"
For i = 1 To ActiveWorkbook.Sheets.Count
If Sheets(i).Name = Worksheets("veri").Range("c20") Then
MsgBox "bu dosya mevcut"
deg = 1
End If
Next
If deg = 0 Then
Sheets("tutanak").Select
Sheets(ActiveSheet.Name).Copy After:=Sheets(Sheets.Count)
Sheets(ActiveSheet.Name).Name = Worksheets("veri").Range("c20")
Dim x As Range
For Each x In [A5:H18]
If x.Value <> "" Then
x.Value = x.Value
End If
Next x
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
End With
Sheets("veri").Select
MsgBox "işlem tamam"
End If
End Sub
Genişletmek için tıkla ...
 
halit3 arkadaşım ilgilen teşekkürler ancak hata verdi ve yeni açtığı sayfayı (Tutanak(1),Tutanak(2) gibi açıyor ve c20 de verilen numaraya bağımlı isim açmıyor.
 
ayemenici' Alıntı:
halit3 arkadaşım ilgilen teşekkürler ancak hata verdi ve yeni açtığı sayfayı (Tutanak(1),Tutanak(2) gibi açıyor ve c20 de verilen numaraya bağımlı isim açmıyor.
Genişletmek için tıkla ...

c20 hücresinin formatını metin olarak yapıp yeniden denermisiniz.
 
sayın halit3 arkadaşım, sonuç olumlu demiştim ancak bir hata verdi,
kopyalanan "tutanak" sayfasında bazı kodlar var bunlarda kopyalandığı için hata veriyor, bu kodların yeni eklenen sayfaya kopyalanmasını engelleyebilirmiyiz.
 
ayemenici' Alıntı:
sayın halit3 arkadaşım, sonuç olumlu demiştim ancak bir hata verdi,
kopyalanan "tutanak" sayfasında bazı kodlar var bunlarda kopyalandığı için hata veriyor, bu kodların yeni eklenen sayfaya kopyalanmasını engelleyebilirmiyiz.
Genişletmek için tıkla ...

neyi engelliyeceğiz örnek dosya ile belirtiniz.
 
ayemenici' Alıntı:
ekte gönderdiğim dosyayı bir incele
Genişletmek için tıkla ...

Ekli dosyanızda tutanak sayfasında aşağıdaki kodu sildim bu kod aktar makrosunu tetikliyor ve dosyayı kapatıyor bunu iptal edince dosyadaki makro istediğiniz sonucu veriyor.

Kod: 
Private Sub Worksheet_Deactivate()
If Val(ThisWorkbook.kayıt) = 0 Then
  Application.OnKey "{del}"
  End If
End Sub
 

Ekli dosyalar

bu seferde tutanak veya yeni eklenen sayfayı açmaya çalışınca hata veriyor.
işin özü tutanak sayfası değeşken olduğu için yeni sayfa eklenince buraya biçim ve değer olarak kopyalaması alttaki kodları kopyalamasın.
 
ayemenici' Alıntı:
bu seferde tutanak veya yeni eklenen sayfayı açmaya çalışınca hata veriyor.
işin özü tutanak sayfası değeşken olduğu için yeni sayfa eklenince buraya biçim ve değer olarak kopyalaması alttaki kodları kopyalamasın.
Genişletmek için tıkla ...

ilk mesajındaki dosyada tutanak sayfasınını kod bölümünde makrolar yoktu kodlar ona göre yazılmıştı şimdi kodları yeniden yazmak ihtiyacı doğdu önceden dosyanızın tutak sayfasındaki kod bölümünde makrolar var deseydiniz veya örnek dosyanızı esas dosyanızla aynı olarak gönderseydiniz.kodları yeniden yazma ihtiyacı olmuyacaktı.

ekli dosyanızı kontrol ediniz.
 

Ekli dosyalar

çok yer kapladığı için kodları koymamıştım. asıl dosya daha fazla yer tutuyor o yüzden örnek hazırladım. gönderdiğin dosyada yaptığın düzeltmeyi inceledim ancak bu seferde tutanak sayfasındaki birleştirilen hücreleri ayırarak kopyalıyor.
 
ayemenici' Alıntı:
çok yer kapladığı için kodları koymamıştım. asıl dosya daha fazla yer tutuyor o yüzden örnek hazırladım. gönderdiğin dosyada yaptığın düzeltmeyi inceledim ancak bu seferde tutanak sayfasındaki birleştirilen hücreleri ayırarak kopyalıyor.
Genişletmek için tıkla ...

kod tutanak sayfasının kopyalamıyor kod kendisi yeniden sayfa oluşturuyor

hücrelerin birleşik olmamasında bir mahsur varmı.?
 
tutanak sayfasının neresinde birleştirilmiş hücre var ben bulamadım.
 
halit3 arkadaşım senin gönderdiğin kod un bir kısmını kullanarak sorunu çözdüm ilgin için çok teşekkür. aşağıdaki kodun
"Sheets("tutanak").Shapes("Picture 1").Copy"
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
Dim x As Range"

kısmını ekledim. sorun çözüldü biraz uzun sürüyor ancak sonuç olumlu










Sub Sayfa_Ekle()
Dim U As Long, S1 As Worksheet
BAŞLA:
Set S1 = Sheets("veri")
U = 1
ActiveSheet.Unprotect Password:="abdullah"
S1.Range("IV:IV").ClearContents
For Each Sayfalar In Worksheets
If Sayfalar.Name <> "veri" Then
S1.Cells(U, "IV") = Sayfalar.Name
U = U + 20
End If
Next
For U = 20 To S1.Range("C20").End(2).Row
If S1.Cells(U, "C") <> "veri" Then
If S1.Cells(U, "C") <> "" Then
Say = WorksheetFunction.CountIf(S1.Range("IV:IV"), S1.Cells(U, "C"))
If Say = 0 Then
ActiveSheet.Protect Password:="abdullah", DrawingObjects:=True, Contents:=True, Scenarios:=True
Sheets("tutanak").Select
Cells.Select
Selection.Copy

Sheets.Add After:=Sheets((Worksheets.Count))

ActiveSheet.Name = S1.Cells(U, "c")
ActiveSheet.Unprotect Password:="abdullah"
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
.DisplayZeros = False
End With
ActiveWindow.Zoom = 75


Sheets("tutanak").Shapes("Picture 1").Copy
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
Dim x As Range


With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.196850393700787)
.RightMargin = Application.InchesToPoints(0.15748031496063)
.TopMargin = Application.InchesToPoints(0.354330708661417)
.BottomMargin = Application.InchesToPoints(0.275590551181102)
.HeaderMargin = Application.InchesToPoints(0.15748031496063)
.FooterMargin = Application.InchesToPoints(0.15748031496063)
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With
Application.CutCopyMode = False
ActiveSheet.Protect Password:="abdullah", DrawingObjects:=True, Contents:=True, Scenarios:=True
Sheets("veri").Select
Sheets("kayıt").Select
Range("A3").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
If Range("A3").Value = "" Then
Range("A3").Value = 1
Range("A3").Select
Else
ActiveCell.Value = ActiveCell.Offset(-1, 0).Value + 1
End If
ActiveCell.Offset(0, 1).Value = Worksheets("veri").Range("c20")
ActiveCell.Offset(0, 2).Value = Worksheets("veri").Range("c18")
ActiveCell.Offset(0, 3).Value = Worksheets("Tutanak").Range("c91")
ActiveCell.Offset(0, 4).Value = Worksheets("Tutanak").Range("l65")
ActiveCell.Offset(0, 5).Value = Worksheets("veri").Range("b38")
ActiveCell.Offset(0, 6).Value = Worksheets("veri").Range("c3")
Sheets("VERİ").Select
Exit Sub

GoTo BAŞLA
End If
Sheets("veri").Select
MsgBox "BU SAYILI TUTANAK MEVCUTTUR! YENİ BİR SAYI GİRİN...", vbCritical
Exit Sub
End If
End If
S1.Range("IV:IV").ClearContents

Next
ActiveSheet.Protect Password:="abdullah", DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
 
Sorunun çözüldüyse size iyi çalışmalar diliyorum.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst