resim kes yapıştır.

halit3 · 24 Mart 2019

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

halit3 · 24 Mart 2019

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

halit3 · 24 Mart 2019

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ı

euphrates55 · 24 Mart 2019

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 · 24 Mart 2019

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 · 24 Mart 2019

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 · 24 Mart 2019

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

euphrates55 · 24 Mart 2019

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 · 24 Mart 2019

sorun ofis 2016 da galiba kayıt yaptığınız dosyada resimler gözüküyormu

euphrates55 · 24 Mart 2019

halit3' Alıntı:
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.

halit3 · 24 Mart 2019

ç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

euphrates55 · 24 Mart 2019

çok enteresan. ben de size gönderdim. 35 kb boyutu. telefonda açınca içinde resim yok.

halit3 · 24 Mart 2019

Kendime mail gönderdim va aldım sonrada dosyayı açtım resim gözüküyor.

halit3 · 24 Mart 2019

dosya

Orion1 · 24 Mart 2019

Sayın [U]euphrates55[/U]

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

euphrates55 · 24 Mart 2019

Orion1' Alıntı:
Sayın [U]euphrates55[/U]

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

makroluk bir şey yok sayın orion. sadece dosya açılıp bakılacak. makroluk kısım, önceden raporlamak için yapılıyor.

euphrates55 · 24 Mart 2019

halit3' Alıntı:
dosya

Halit Bey, son hali ile dosyanızda, firma isimleri değiştikçe resimler değişiyor mu

halit3 · 24 Mart 2019

evet resimler mevcut sa değişiyor

euphrates55 · 24 Mart 2019

halit3' Alıntı:
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 · 24 Mart 2019

siz bu mesajları ve kodları cep telefonuyla mı yapıyordunuz.

resim kes yapıştır.

halit3

Uzman

halit3

Uzman

halit3

Uzman

euphrates55

halit3

Uzman

halit3

Uzman

halit3

Uzman

euphrates55

halit3

Uzman

euphrates55

halit3

Uzman

euphrates55

halit3

Uzman

halit3

Uzman

Ekli dosyalar

Orion1

Uzman

euphrates55

euphrates55

halit3

Uzman

euphrates55

halit3

Uzman