• DİKKAT

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

resim kes yapıştır.

Merhaba dosyanızı indirdim dosyanızda 15 nolu mesajdaki kodu göremedim.
sunu sayfasında K15:S15 aralığında bir resim olması lazım bu resim yok
 
halit3' Alıntı:
Merhaba dosyanızı indirdim dosyanızda 15 nolu mesajdaki kodu göremedim.
sunu sayfasında K15:S15 aralığında bir resim olması lazım bu resim yok
Genişletmek için tıkla ...
her şeyin düzgün olduğu hali bu. bundan sonra yapılacaklar için çalışıyordum. o sırada göndermiştim. dolayısı ile olmayabilir. bundan sonrası için eti sizin kemiği benim. her türlü işlem için hazır. önemli olan derdimi anlatabildim mi. umarım anlatabilmişimdir. yeni fikirlere de açığım tabi.
 
HÜCRE GİRİŞ sayfasında T sutununda #DEĞER! hatası var (('C:\Users\msi\AppData\Roaming\Microsoft\AddIns\Hsr_Ozel_Menu&Fonk.xla'!UCASETR(S1));)
formülün içinde özel eklenti kodu var bu neyi ifade ediyor.
 
resim adını nereden alıyor sunu sayfasında v1 hücresinde #DEĞER! hatası var
 
halit3' Alıntı:
resim adını nereden alıyor sunu sayfasında v1 hücresinde #DEĞER! hatası var
Genişletmek için tıkla ...
hücre girişi t1 e
=KIRP(EĞER(UZUNLUK(BÜYÜKHARF((BİRLEŞTİR(İlkharfler(UCASETR(S1));"+";YERİNEKOY(SOLDAN(Q1;12);":";"=");"-";SOLDAN(R1;9)))))>31;SOLDAN(BÜYÜKHARF((BİRLEŞTİR(İlkharfler(UCASETR(S1));"+";YERİNEKOY(SOLDAN(Q1;12);":";"=");"-";SOLDAN(R1;9))));31);BÜYÜKHARF((BİRLEŞTİR(İlkharfler(UCASETR(S1));"+";YERİNEKOY(SOLDAN(Q1;12);":";"=");"-";SOLDAN(R1;9))))))

kopyalayıp aşağı çekerseniz düzelir. eklenti ile ilgili bir sıkıntı oldu ve bir daha da çözemedim. kafasına göre çıkıyor ve düzeltemiyorum. ama yolunu biliyorum. sorun olmuyor.
 
tam olarak ne yapmak istiyorsunuz anlamadım 15 nolu mesajdaki kodunuz da burada yok
sunu sayfasına V1 hücresine (AM.TU.TO+İHALE 1-FİRMA) 1 bunu yazdım
HÜCRE GİRİŞ sayfasına T1 ve T2 hücresine (AM.TU.TO+İHALE 1-FİRMA 1) bunu yazdım ve sunu sayfası V3 hücresinede ihale2 yazdım ve resmi sunu sayfasına K15: S15 aralığına bir resim getirdi.
sunu sayfasında ADET OLARAK RAPOR düğmesine tıkladım 2 adet seçtim ve bir adet dosyayı ekliyorum.
bundan sonra ne yapmak istiyorsanız anlamadım.
 

Ekli dosyalar

bir yere bir şey yazmanıza gerek yok direk rapora basın. ilgili klasöre excel dosyaları atacak. her sekmede bunu yapınız. attığı excel dosyalarında her biri ayrı ayrı iş olarak bulunacak. siz rapor sayısını 4 seçin. 4 örnek gönderdim. birisi özellikle resimsiz. bu dosyalardan birini sizin bilgisayarınız hariç bir yerden bakınız. telefon da olur. burada işte pc de gözüken resimler gözükmüyor olacak. benim derdim de bu. başka yerde de gözüksün. karışık gelecektir size normal tabi. sizin başka yerlere odaklanmanıza gerek yok. rapora basın 4 seçin. sonra da başka yerde bu excel dosyalarında resimlerin gözükmesi için ne yapmalı onu düşünün. yani düşünürseniz sevinirim [emoji4]


Tapatalk kullanarak iPhone aracılığıyla gönderildi
 
sizin dosyanıza bir şeyler yapıyorum kayıt edip kapatınca dosya eski haliyle açılıyor
bende ofis 2007 var bu durumda bir ilerleme kayıt edemedim.
 
önemli değil. çabanız yeter. teşekkürler.


Tapatalk kullanarak iPhone aracılığıyla gönderildi
 
sunu sayfasının içindeki kodu bununla değiştirip denermisiniz.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
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


Set Adres = ActiveSheet.Range("k15:s15")

If CreateObject("Scripting.FileSystemObject").FileExists(dosya) = True Then
MsgBox dosya
ad = ActiveSheet.Pictures.Insert(dosya).Name
's1.Shapes(ad).OLEFormat.Object.Select
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
ActiveSheet.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 1
ActiveSheet.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 1
ActiveSheet.Shapes(ad).OLEFormat.Object.Height = Adres.Height - 2
ActiveSheet.Shapes(ad).OLEFormat.Object.Width = Adres.Width - 2
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
 
kodlarınızda bu kodu kullanmamaya özen gösteriniz.

On Error Resume Next
 
birde şunu yazayım rapor alınca 4 yazınca resimler değişiyor
bu resimlerin hepsi aynı mı değişiyor
yoksa 4 resimde aynı olarak mı değişiyor
 
halit3' Alıntı:
birde şunu yazayım rapor alınca 4 yazınca resimler değişiyor bu resimlerin hepsi aynımı
Genişletmek için tıkla ...

resimlerin değişmesi lazım zaten. onlar örnek olsun diye internetten indirdim. v3 hücresi sırayla değişiyor ve her ihalenin ayrı resim ve haritaları var. her ihale için ayrı excel dosyası, hepsi kendi harita ve resimleri ile kaydediliyor. bunu da v3 hücresindeki ihale adına göre v1 e başvurup o isimle resim ve harita arayıp ekliyor


Tapatalk kullanarak iPhone aracılığıyla gönderildi
 
halit3' Alıntı:
sunu sayfasının içindeki kodu bununla değiştirip denermisiniz.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
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


Set Adres = ActiveSheet.Range("k15:s15")

If CreateObject("Scripting.FileSystemObject").FileExists(dosya) = True Then
MsgBox dosya
ad = ActiveSheet.Pictures.Insert(dosya).Name
's1.Shapes(ad).OLEFormat.Object.Select
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
ActiveSheet.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 1
ActiveSheet.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 1
ActiveSheet.Shapes(ad).OLEFormat.Object.Height = Adres.Height - 2
ActiveSheet.Shapes(ad).OLEFormat.Object.Width = Adres.Width - 2
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
Genişletmek için tıkla ...
bu kod resimleri eklemiyor.
 
rapor kodunun bununla değiştirip denermisiniz.

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
IActiveSheet.Range("W3").Value = ""

For sat = 1 To xy

Sheets("Sunu").Select
yol = ThisWorkbook.Path & "\GEREKLİDOSYALAR" & "\" & "haritalar\"
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 Adres = ActiveSheet.Range("k15:s15")

dosya = yol & HG.Cells(sat, "Q") & ".png"
If CreateObject("Scripting.FileSystemObject").FileExists(dosya) = True Then
ad = ActiveSheet.Pictures.Insert(dosya).Name
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
ActiveSheet.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 1
ActiveSheet.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 1
ActiveSheet.Shapes(ad).OLEFormat.Object.Height = Adres.Height - 2
ActiveSheet.Shapes(ad).OLEFormat.Object.Width = Adres.Width - 2

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
 
kendi resim ekleme kodunuzu ekledim oda olmaz ise bunu deneyiniz.

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
IActiveSheet.Range("W3").Value = ""

For sat = 1 To xy

Sheets("Sunu").Select
yol = ThisWorkbook.Path & "\GEREKLİDOSYALAR" & "\" & "haritalar\"
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 Adres = ActiveSheet.Range("k15:s15")

dosya = yol & HG.Cells(sat, "Q") & ".png"
If CreateObject("Scripting.FileSystemObject").FileExists(dosya) = True Then


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
End If

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
 
halit bey, çok zahmet oluyor. o yüzden yormayayım ben sizi. son kodlarınızda resimler eklenmiyor. daha doğrusu v3 deki döngü sağlanmıyor. aslında yanınızda olsam anlatsam şimdi anladım diyeceksiniz. sonrada çözeceksiniz. yormayayım ben sizi. ben sizin kodları kurcalayıp bakarım. kodlara hakim değilim ama olaya hakimim.


Tapatalk kullanarak iPhone aracılığıyla gönderildi
 
cevaplarınızı yazarken mesaj numarasını vererek yazınız 37 nolu mesajda tamda burada
dosya = yol & HG.Cells(sat, "Q") & ".png"
döngü oluyor
 
halit3' Alıntı:
cevaplarınızı yazarken mesaj numarasını vererek yazınız 37 nolu mesajda tamda burada
dosya = yol & HG.Cells(sat, "Q") & ".png"
döngü oluyor
Genişletmek için tıkla ...

dışarı çıkardığı exceller boş oluyor ama. daha doğrusu bağlantılı resim görüntülenemiyor diyor.


Tapatalk kullanarak iPhone aracılığıyla gönderildi
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst