resim kes yapıştır.

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,799
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
O zaman şöyle yapalım sunu sayfası W3 hücresine OK yazınca sunu sayfasındaki bu kod çalışır siz W3 hücresine bir şey yazmayınız ve bu kodu oraya ekleyiniz.
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)

If ActiveSheet.Cells(4, "W").Value = "OK" Then: Exit Sub
If Intersect(Target, Range("V3")) Is Nothing Then Exit Sub
Sheets("Sunu").Select
yol = ThisWorkbook.Path & "\GEREKLİDOSYALAR" & "\" & "haritalar\"
Rem aralıktaki resmi sil
Set alan = Range("k15:s15")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, alan) Is Nothing Then
resimm.Delete
End If
Next
Set alan = Nothing
Rem silme işleminin sonu

If Dir(yol & Cells(1, "V").Value & ".png") <> "" Then
dosya = Cells(1, "V").Value & ".png"
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(15, "k")
t = .Top
l = .Left
W = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.ShapeRange.LockAspectRatio = msoFalse
.Top = t + 1
.Left = l + 1
.Width = W - 2
.Height = h - 2
End With
Set P = Nothing
End If


Set s = Sheets("sunu")

If s.[c19] >= 0 And s.[c19] < 150 Then
s.[c2].Font.Name = "Palatino Linotype"
s.[c2].Font.Size = 16


ElseIf s.[c19] >= 150 And s.[c19] < 2000 Then
s.[c2].Font.Name = "Palatino Linotype"
s.[c2].Font.Size = 12

End If


Set s = Sheets("sunu")
s.[b15].HorizontalAlignment = xlJustify 'İKİ YANA YASLI yatay


If s.[b19] >= 0 And s.[b19] < 300 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 26


ElseIf s.[b19] >= 301 And s.[b19] < 400 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 24

ElseIf s.[b19] >= 401 And s.[b19] < 500 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 22


ElseIf s.[b19] >= 501 And s.[b19] < 600 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 20


ElseIf s.[b19] >= 601 And s.[b19] < 700 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 18

ElseIf s.[b19] >= 701 And s.[b19] < 800 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 17


ElseIf s.[b19] >= 801 And s.[b19] < 1000 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 16


ElseIf s.[b19] >= 1001 And s.[b19] < 1200 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 14


ElseIf s.[b19] >= 1201 And s.[b19] < 1400 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 12


ElseIf s.[b19] >= 1401 And s.[b19] < 1600 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 11

ElseIf s.[b19] >= 1601 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 9
End If







End Sub
rapor kodunuda bununla değiştir.

Kod:
Public bekle
Sub DIŞARI_RAPOR_SUNU()
MsgBox "EXCEL DOSYASININ OLDUĞU BU DİZİNDE, RAPORLAR VE İÇİNDE DE İHALELER ADLI KLASÖRÜN OLMALI ", vbExclamation, "FIRAT UYARIYOR!"
Secim = MsgBox("BU ŞARTLAR SAĞLANDI MI?", vbYesNo + vbCritical, "İYİ DÜŞÜN")
If Secim = vbYes Then
Application.Visible = True
ElseIf Secim = vbNo Then
MsgBox "PEKİ, İPTAL EDEYİM BARİ!", vbMsgBoxSetForeground
Exit Sub
End If
    Dim basla, bitir, süre
    Dim i As Long
    basla = Timer
Set HG = Sheets("HÜCRE GİRİŞ"): Set s = Sheets("sunu")
bekle = "DUR"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
xy = InputBox("KAÇ İHALE RAPORLANACAK. YAZ. GT DEKİ SIRALAMA")
If xy = "" Then
MsgBox "yazmadın, çıkıyorum...", vbInformation, "        Uyarı"
Exit Sub
End If
    For sat = 1 To xy
   
        s.[V3] = HG.Cells(sat, "Q")

yol = ThisWorkbook.Path & "\GEREKLİDOSYALAR" & "\" & "haritalar\"
dosya = yol & Cells(1, "V").Value & ".png"
If CreateObject("Scripting.FileSystemObject").FileExists(dosya) = True Then

Set alan = Range("k15:s15")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, alan) Is Nothing Then
resimm.Delete
End If
Next
Set alan = Nothing

Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(15, "k")
t = .Top
l = .Left
W = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.ShapeRange.LockAspectRatio = msoFalse
.Top = t + 1
.Left = l + 1
.Width = W - 2
.Height = h - 2
End With
Set P = Nothing


       
        ActiveSheet.Copy
        belge = ThisWorkbook.Path & "\RAPORLAR" & "\İHALELER\" & Replace(Replace(HG.Cells(sat, "T").Value, ":", "="), "/", "&") & ".xlsx"
        ActiveWorkbook.SaveAs belge
        ActiveWorkbook.Close
     End If
    Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
bekle = ""
bitir = Timer
MsgBox "İhalelelerin Dışarı aktarımı " & Format(bitir - basla, "Fixed") & " saniyede Tamamlandı", vbInformation
End Sub
 
Son düzenleme:

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,799
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
41 nolu mesajdaki rapor koduna ilave yaptım

Rich (BB code):
Public bekle
Sub DIŞARI_RAPOR_SUNU()
MsgBox "EXCEL DOSYASININ OLDUĞU BU DİZİNDE, RAPORLAR VE İÇİNDE DE İHALELER ADLI KLASÖRÜN OLMALI ", vbExclamation, "FIRAT UYARIYOR!"
Secim = MsgBox("BU ŞARTLAR SAĞLANDI MI?", vbYesNo + vbCritical, "İYİ DÜŞÜN")
If Secim = vbYes Then
Application.Visible = True
ElseIf Secim = vbNo Then
MsgBox "PEKİ, İPTAL EDEYİM BARİ!", vbMsgBoxSetForeground
Exit Sub
End If
    Dim basla, bitir, süre
    Dim i As Long
    basla = Timer
Set HG = Sheets("HÜCRE GİRİŞ"): Set s = Sheets("sunu")
bekle = "DUR"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
xy = InputBox("KAÇ İHALE RAPORLANACAK. YAZ. GT DEKİ SIRALAMA")
If xy = "" Then
MsgBox "yazmadın, çıkıyorum...", vbInformation, "        Uyarı"
Exit Sub
End If
    For sat = 1 To xy
   
        s.[V3] = HG.Cells(sat, "Q")

yol = ThisWorkbook.Path & "\GEREKLİDOSYALAR" & "\" & "haritalar\"
dosya = yol & Cells(1, "V").Value & ".png"
If CreateObject("Scripting.FileSystemObject").FileExists(dosya) = True Then

Set alan = Range("k15:s15")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, alan) Is Nothing Then
resimm.Delete
End If
Next
Set alan = Nothing


Set P = ActiveSheet.Pictures.Insert(dosya)
With Cells(15, "k")
t = .Top
l = .Left
W = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.ShapeRange.LockAspectRatio = msoFalse
.Top = t + 1
.Left = l + 1
.Width = W - 2
.Height = h - 2
End With
Set P = Nothing


       
        ActiveSheet.Copy
        belge = ThisWorkbook.Path & "\RAPORLAR" & "\İHALELER\" & Replace(Replace(HG.Cells(sat, "T").Value, ":", "="), "/", "&") & ".xlsx"
        ActiveWorkbook.SaveAs belge
        ActiveWorkbook.Close
     End If
    Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
bekle = ""
bitir = Timer
MsgBox "İhalelelerin Dışarı aktarımı " & Format(bitir - basla, "Fixed") & " saniyede Tamamlandı", vbInformation
End Sub
 
Son düzenleme:

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,799
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
42 nolu mesajdaki kodun kırmızı yerini güncelledim
kod bendeki dosyada çalışıyor rapor da 4 yazdım ve 1 dosya kayıt yaptı çünkü bir resim mevcut diğerleri olmadığından kayıt yapmadı
 
Katılım
25 Ocak 2006
Mesajlar
763
Excel Vers. ve Dili
2019 tr
Altın Üyelik Bitiş Tarihi
04-01-2024
pc başında değilim halit bey. en kısa zamanda bilgilendireceğim sizi. teşekkürler


Tapatalk kullanarak iPhone aracılığıyla gönderildi
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,799
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Biraz karıştı konu ama ben farklı bir yol deneyeceğim.bir modül oluştur içine bu kodu yapıştır.

Kod:
Sub aktar()

Sheets("Sunu").Select
yol = ThisWorkbook.Path & "\GEREKLİDOSYALAR" & "\" & "haritalar\"
Rem aralıktaki resmi sil
Set alan = Range("k15:s15")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, alan) Is Nothing Then
resimm.Delete
End If
Next
Set alan = Nothing
Rem silme işleminin sonu

If Dir(yol & Cells(1, "V").Value & ".png") <> "" Then
dosya = Cells(1, "V").Value & ".png"
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(15, "k")
t = .Top
l = .Left
W = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.ShapeRange.LockAspectRatio = msoFalse
.Top = t + 1
.Left = l + 1
.Width = W - 2
.Height = h - 2
End With
Set P = Nothing
End If


Set s = Sheets("sunu")

If s.[c19] >= 0 And s.[c19] < 150 Then
s.[c2].Font.Name = "Palatino Linotype"
s.[c2].Font.Size = 16


ElseIf s.[c19] >= 150 And s.[c19] < 2000 Then
s.[c2].Font.Name = "Palatino Linotype"
s.[c2].Font.Size = 12

End If


Set s = Sheets("sunu")
s.[b15].HorizontalAlignment = xlJustify 'İKİ YANA YASLI yatay


If s.[b19] >= 0 And s.[b19] < 300 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 26


ElseIf s.[b19] >= 301 And s.[b19] < 400 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 24

ElseIf s.[b19] >= 401 And s.[b19] < 500 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 22


ElseIf s.[b19] >= 501 And s.[b19] < 600 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 20


ElseIf s.[b19] >= 601 And s.[b19] < 700 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 18

ElseIf s.[b19] >= 701 And s.[b19] < 800 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 17


ElseIf s.[b19] >= 801 And s.[b19] < 1000 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 16


ElseIf s.[b19] >= 1001 And s.[b19] < 1200 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 14


ElseIf s.[b19] >= 1201 And s.[b19] < 1400 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 12


ElseIf s.[b19] >= 1401 And s.[b19] < 1600 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 11

ElseIf s.[b19] >= 1601 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 9
End If

End Sub
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,799
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
sunu sayfasındaki kodu da bununla değişitir
uyarı sunu sayfasında V3 hücresine giriş yapınca kodun çalışması için W4 hücresine ("OK") yazınız

Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
If ActiveSheet.Cells(4, "W").Value = "OK" Then: Exit Sub
If Intersect(Target, Range("V3")) Is Nothing Then Exit Sub
aktar

End Sub
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,799
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
aktar kodunu da bununla değiştirin

Kod:
Public bekle
Sub DIŞARI_RAPOR_SUNU()
MsgBox "EXCEL DOSYASININ OLDUĞU BU DİZİNDE, RAPORLAR VE İÇİNDE DE İHALELER ADLI KLASÖRÜN OLMALI ", vbExclamation, "FIRAT UYARIYOR!"
Secim = MsgBox("BU ŞARTLAR SAĞLANDI MI?", vbYesNo + vbCritical, "İYİ DÜŞÜN")
If Secim = vbYes Then
Application.Visible = True
ElseIf Secim = vbNo Then
MsgBox "PEKİ, İPTAL EDEYİM BARİ!", vbMsgBoxSetForeground
Exit Sub
End If
    Dim basla, bitir, süre
    Dim i As Long
    basla = Timer
Set HG = Sheets("HÜCRE GİRİŞ"): Set s = Sheets("sunu")
bekle = "DUR"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 xy = InputBox("KAÇ İHALE RAPORLANACAK. YAZ. GT DEKİ SIRALAMA")
 If xy = "" Then
MsgBox "yazmadın, çıkıyorum...", vbInformation, "        Uyarı"
Exit Sub
End If
ActiveSheet.Cells(4, "W").Value = ""

    For sat = 1 To xy
    
        s.[V3] = HG.Cells(sat, "Q")

yol = ThisWorkbook.Path & "\GEREKLİDOSYALAR" & "\" & "haritalar\"
dosya = yol & Cells(1, "V").Value & ".png"
If CreateObject("Scripting.FileSystemObject").FileExists(dosya) = True Then

aktar
        ActiveSheet.Copy
        belge = ThisWorkbook.Path & "\RAPORLAR" & "\İHALELER\" & Replace(Replace(HG.Cells(sat, "T").Value, ":", "="), "/", "&") & ".xlsx"
        ActiveWorkbook.SaveAs belge
        ActiveWorkbook.Close
     End If
    Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
bekle = ""
bitir = Timer
MsgBox "İhalelelerin Dışarı aktarımı " & Format(bitir - basla, "Fixed") & " saniyede Tamamlandı", vbInformation
End Sub
 
Katılım
25 Ocak 2006
Mesajlar
763
Excel Vers. ve Dili
2019 tr
Altın Üyelik Bitiş Tarihi
04-01-2024
dediklerinizi uyguladım, eklenen excellerden birini kendime mail attım telefonda açtım ama resim gözükmüyor. sanırım olmuyor. daha fazla uğraşmayın lütfen. çok uğraştırdım sizi. emeğinize sağlık.
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,799
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
sorun ofis 2016 da galiba kayıt yaptığınız dosyada resimler gözüküyormu
 
Katılım
25 Ocak 2006
Mesajlar
763
Excel Vers. ve Dili
2019 tr
Altın Üyelik Bitiş Tarihi
04-01-2024
sorun ofis 2016 da galiba
biraz da olay başka yerlere kaydı. ben sadece dışarı çıkarılan excellerdeki resimlerin içinde kalması ve başka pc lerde de açılıp görünmesini istiyorum. bizim kodlarımızda resmi eklemiyor. sadece exceli açtığımızda tekrar gösteriyor.
kodlarımda gereksiz ve yanlış yorumlar olabilir ama sonuç olarak çalışıyor.
çok basit bir örnekle açıklamak gerekirse; dışarı çıkan excelin boyutu 35 Kb. fakat resim içinde olsa çok daha fazla olmalı. sizin yaptığınızda excelin boyutu ne oluyor bilmiyorum ama sizde de 35 kb ise sizde de istediğim olmamış demektir. aşağıdaki resimlerin boyutu olayı açıklıyor. birisi aktarımla gelen dosya diğeri ise aktarımla gelen dosyadaki resmi kesip tekrar resim olarak yapıştırarak kaydettiğim dosya. fark ortada.fark.jpg
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,799
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
çalışan dosyayı mesajla gönderdim
50 nolu surunuza ise cevap yazıyorum dosya boyutu 145 KB dosyayı açınca da resimler gözüküyor.
sizin bana gönderdiğiniz dosyalarda resimler gözükmüyordu
 
Katılım
25 Ocak 2006
Mesajlar
763
Excel Vers. ve Dili
2019 tr
Altın Üyelik Bitiş Tarihi
04-01-2024
çok enteresan. ben de size gönderdim. 35 kb boyutu. telefonda açınca içinde resim yok.
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,799
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Kendime mail gönderdim va aldım sonrada dosyayı açtım resim gözüküyor.
 

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Sayın [U]euphrates55[/U]

Telefonda makrolar çalışmıyor.
Bunu dikkate aldınızmı?
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,799
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
evet resimler mevcut sa değişiyor
 
Katılım
25 Ocak 2006
Mesajlar
763
Excel Vers. ve Dili
2019 tr
Altın Üyelik Bitiş Tarihi
04-01-2024
evet resimler mevcut sa değişiyor
bilemedim. son ana dosyayı sizden alıp benimkiyle değiştim. bende resimler değişmiyor. ben pes ettim. :) dediğim gibi yarın iş yerinde de deneyeceğim.

klasörlerle beraber mesaj atabilir misniz son hali.
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,799
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
siz bu mesajları ve kodları cep telefonuyla mı yapıyordunuz.
 
Üst