- Katılım
- 25 Ocak 2006
- Mesajlar
- 763
- Excel Vers. ve Dili
- 2019 tr
- Altın Üyelik Bitiş Tarihi
- 04-01-2024
-
DİKKAT DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
resim kes yapıştır.
- Konbuyu başlatan euphrates55
- Başlangıç tarihi
- Katılım
- 25 Ocak 2006
- Mesajlar
- 763
- Excel Vers. ve Dili
- 2019 tr
- Altın Üyelik Bitiş Tarihi
- 04-01-2024
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.
- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,840
- Excel Vers. ve Dili
-
2003 excell türkçe
ve
2007 excell türkçe
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.
formülün içinde özel eklenti kodu var bu neyi ifade ediyor.
- Katılım
- 25 Ocak 2006
- Mesajlar
- 763
- Excel Vers. ve Dili
- 2019 tr
- Altın Üyelik Bitiş Tarihi
- 04-01-2024
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.
- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,840
- Excel Vers. ve Dili
-
2003 excell türkçe
ve
2007 excell türkçe
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.
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.
- Katılım
- 25 Ocak 2006
- Mesajlar
- 763
- Excel Vers. ve Dili
- 2019 tr
- Altın Üyelik Bitiş Tarihi
- 04-01-2024
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
Tapatalk kullanarak iPhone aracılığıyla gönderildi
- Katılım
- 25 Ocak 2006
- Mesajlar
- 763
- Excel Vers. ve Dili
- 2019 tr
- Altın Üyelik Bitiş Tarihi
- 04-01-2024
önemli değil. çabanız yeter. teşekkürler.
Tapatalk kullanarak iPhone aracılığıyla gönderildi
Tapatalk kullanarak iPhone aracılığıyla gönderildi
- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,840
- Excel Vers. ve Dili
-
2003 excell türkçe
ve
2007 excell türkçe
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- Katılım
- 25 Ocak 2006
- Mesajlar
- 763
- Excel Vers. ve Dili
- 2019 tr
- Altın Üyelik Bitiş Tarihi
- 04-01-2024
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
- Katılım
- 25 Ocak 2006
- Mesajlar
- 763
- Excel Vers. ve Dili
- 2019 tr
- Altın Üyelik Bitiş Tarihi
- 04-01-2024
bu kod resimleri eklemiyor.
- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,840
- Excel Vers. ve Dili
-
2003 excell türkçe
ve
2007 excell türkçe
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- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,840
- Excel Vers. ve Dili
-
2003 excell türkçe
ve
2007 excell türkçe
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- Katılım
- 25 Ocak 2006
- Mesajlar
- 763
- Excel Vers. ve Dili
- 2019 tr
- Altın Üyelik Bitiş Tarihi
- 04-01-2024
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
Tapatalk kullanarak iPhone aracılığıyla gönderildi
- Katılım
- 25 Ocak 2006
- Mesajlar
- 763
- Excel Vers. ve Dili
- 2019 tr
- Altın Üyelik Bitiş Tarihi
- 04-01-2024
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