Soru Şablon İsmine Göre Seç ve Getir

H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
499
Excel Vers. ve Dili
2010, Türkiye
Merhabalar;
Ekli örnek dosyada şablon sayfasındaki isimli şablonları (yol, ağaç,Tara(Kırmızı),Tara(Mavi),Dolgu Yok(Mavi),Dolgu Yok(Kırmızı)) Userfom üzerinde bulunan combobox1 den şablon ismine göre seçtiğimde seçilen şablonun hem userform üzerindeki resim1 e ve Seç sayfasındaki B9 hücresinin içersine tam sığacak şekilde gelmesini makro ile nasıl yaparız.
Örneğin: Combobox1 den Ağaç Şablonunun seçtiğimde bu şablon hem userform üzerindeki resmin içersine hemde seç sayfasondaki B9 hücresine gelecek

İndir örnek xlsm

Dosyayı indir örnek xlsm
dosya.co
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
499
Excel Vers. ve Dili
2010, Türkiye
Konuya destek olursanız sevinirim. Hayırlı geceler
 
Biolightant

Biolightant

Katılım
6 Mart 2024
Mesajlar
160
Excel Vers. ve Dili
Excel 2010 TR & Excel 2016 TR
Merhaba,

C++: 
Option Explicit
' https://www.excel.web.tr/threads/sablon-ismine-goere-sec-ve-getir.215070/

Private Sub UserForm_Initialize()
    ' ComboBox1'e öğeler ekleniyor
    With Me.ComboBox1
        .AddItem "Yol"
        .AddItem "Ağaç"
        .AddItem "Tara(Kırmızı)"
        .AddItem "Tara(Mavi)"
        .AddItem "Dolgu Yok (Mavi)"
        .AddItem "Dolgu Yok (Kırmızı)"
        
        ' "Dolgu Yok(Mavi)" varsayılan olarak seçiliyor
        .Value = "Dolgu Yok (Mavi)"
        
        ' Kullanıcının yalnızca listedekileri seçmesini sağla
        .Style = fmStyleDropDownList
    End With
End Sub

Private Sub ComboBox1_Change()

    Dim FotoAdres As String
    Dim MyJpg As Picture
    
    Dim SecimShape As Shape
    Set SecimShape = Sheets("ŞABLON").Shapes(Me.ComboBox1.Value)
    
    ' Şeklin veya Resmin fotoğrafını oluştur
    Call Shapes_Foto_Cek(SecimShape)
    
    ' Fotoğrafın temp klasöründeki TamYolu
    FotoAdres = Environ$("temp") & "\ExcelShapesFoto.jpg"
    
    ' ***** Hücre fotoğrafını Image1 e ekle *****
    Me.Image1.Picture = LoadPicture(FotoAdres)
        
    ' ***** Hücre fotoğrafını B9 hücresine ekle *****
    ' Eski Foto varsa sil
    On Error Resume Next
        Sheets("SEÇ").Shapes("Foto-B9").Delete
    On Error GoTo 0
    
    Set MyJpg = Sheets("SEÇ").Pictures.Insert(FotoAdres) ' Sayfaya jpg dosyasını ekle

        ' Foto konumunu, Yükseliğini ve Adını ayarlayalım
        With MyJpg
            .Top = Range("B9").Top
            .Left = Range("B9").Left
            .Height = Range("B9").Height
            .Name = "Foto-B9"
        End With

        ' Eğer resim genişliği hücre genişliğinden büyükse genişliği ayarla
        If MyJpg.Width > Range("B9").Width Then
            MyJpg.Width = Range("B9").Width
        End If
End Sub
Private Sub Shapes_Foto_Cek(FotoShapes As Shape)
    Dim Grafik As Object
    
    ' Şekli kopyala
    FotoShapes.Copy
    
    ' Geçici grafik nesnesi oluştur ve resmi içine yapıştır
    Set Grafik = ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, Width:=FotoShapes.Width, Height:=FotoShapes.Height)
    Grafik.Activate
    Grafik.Chart.Paste
        
    ' Resmi JPG olarak kaydet
    Grafik.Chart.Export Environ$("temp") & "\ExcelShapesFoto.jpg"
    DoEvents
    Grafik.Delete ' Geçici grafik nesnesini sil
    
    Set Grafik = Nothing
End Sub
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
499
Excel Vers. ve Dili
2010, Türkiye
Hocam teşekkür ederim. Yalnız seç sayfasında b9 hücresine şablon resmini alırken aynısını almıyor. Şablon kenar kalınlığını aynı şekilde almıyor
 
M

muhasebeciyiz

Altın Üye
Katılım
10 Şubat 2006
Mesajlar
638
Excel Vers. ve Dili
Office 2016
64 Bit
Altın Üyelik Bitiş Tarihi
21-12-2027
Sorununuz, B9 hücresine resmi eklerken şeklin kenar kalınlıklarının korunmaması ile ilgili. Excel'de resimler eklerken, şeklin kenar özelliklerini doğrudan kopyalamak mümkün olmamaktadır, çünkü resimler yalnızca görsel bir içerik olarak eklenir ve şekil özellikleri (kenar çizgileri, dolgular, vb.) bu resimlere uygulanmaz. Ancak, şablondaki şeklin kenar özelliklerini manuel olarak almak ve ardından bu özellikleri resmin etrafında uygulamak mümkündür.
 
Biolightant

Biolightant

Katılım
6 Mart 2024
Mesajlar
160
Excel Vers. ve Dili
Excel 2010 TR & Excel 2016 TR
@muhasebeciyiz açıklama için teşekkür ederim.

o zaman şöyle bir çözüme gitmek gerekecek
nasılsa UserForm da değil Sayfada işlem yapacağımızdan
direk Şekli (Shape) kopyalayıp yapıştırıp düzenleriz.

Yeni kodlar.

C++: 
Option Explicit
' https://www.excel.web.tr/threads/sablon-ismine-goere-sec-ve-getir.215070/

Private Sub UserForm_Initialize()
    ' ComboBox1'e öğeler ekleniyor
    With Me.ComboBox1
        .AddItem "Yol"
        .AddItem "Ağaç"
        .AddItem "Tara(Kırmızı)"
        .AddItem "Tara(Mavi)"
        .AddItem "Dolgu Yok (Mavi)"
        .AddItem "Dolgu Yok (Kırmızı)"
        
        ' "Dolgu Yok(Mavi)" varsayılan olarak seçiliyor
        .Value = "Dolgu Yok (Mavi)"
        
        ' Kullanıcının yalnızca listedekileri seçmesini sağla
        .Style = fmStyleDropDownList
    End With
End Sub

Private Sub ComboBox1_Change()

    Dim FotoAdres As String

    Dim SecimShape As Shape
    Set SecimShape = Sheets("ŞABLON").Shapes(Me.ComboBox1.Value)

    ' Şeklin veya Resmin fotoğrafını oluştur
    Call Shapes_Foto_Cek(SecimShape)

    ' Fotoğrafın temp klasöründeki TamYolu
    FotoAdres = Environ$("temp") & "\ExcelShapesFoto.jpg"

    ' ***** Hücre fotoğrafını Image1 e ekle *****
    Me.Image1.Picture = LoadPicture(FotoAdres)

    ' ***** Hücre fotoğrafını B9 hücresine ekle *****
    ' Eski Foto varsa sil
    On Error Resume Next
        Sheets("SEÇ").Shapes("Foto-B9").Delete
    On Error GoTo 0

    ' Şekli kopyala ve yapıştır
    SecimShape.Copy
    Sheets("SEÇ").Paste

        ' Şeklin konumunu, Yükseliğini ve Adını ayarlayalım
        With Selection
            .Top = Sheets("SEÇ").Range("B9").Top
            .Left = Sheets("SEÇ").Range("B9").Left
            .Height = Sheets("SEÇ").Range("B9").Height
            .Name = "Foto-B9"
        End With

        ' Eğer resim genişliği hücre genişliğinden büyükse genişliği ayarla
        If Selection.Width > Sheets("SEÇ").Range("B9").Width Then
            Selection.Width = Sheets("SEÇ").Range("B9").Width
        End If

    Sheets("SEÇ").Range("B9").Select

End Sub

Private Sub Shapes_Foto_Cek(FotoShapes As Shape)
    Dim Grafik As Object
    
    ' Şekli kopyala
    FotoShapes.Copy
    
    ' Geçici grafik nesnesi oluştur ve resmi içine yapıştır
    Set Grafik = ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, Width:=FotoShapes.Width, Height:=FotoShapes.Height)
    Grafik.Activate
    Grafik.Chart.Paste
        
    ' Resmi JPG olarak kaydet
    Grafik.Chart.Export Environ$("temp") & "\ExcelShapesFoto.jpg"
    DoEvents
    Grafik.Delete ' Geçici grafik nesnesini sil
    
    Set Grafik = Nothing
End Sub
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
499
Excel Vers. ve Dili
2010, Türkiye
Hocam tekrar merhabalar;
Kod gayet güzel çalışıyor. 2 yerde düzenleme yaparmısınız.
1-Seç sayfasında başka resim varsa onları da siliyor. Onların silinmemesi gerekiyor.
2-Seç sayfasına gelen resmin adı Resim-1 şeklinde olabilir mi?
 
Biolightant

Biolightant

Katılım
6 Mart 2024
Mesajlar
160
Excel Vers. ve Dili
Excel 2010 TR & Excel 2016 TR
Hsn55' Alıntı:
1-Seç sayfasında başka resim varsa onları da siliyor. Onların silinmemesi gerekiyor.
Genişletmek için tıkla ...
C++: 
    ' Eski Foto varsa sil
    On Error Resume Next
        Sheets("SEÇ").Shapes("Foto-B9").Delete
    On Error GoTo 0
bu kod satırlarını
C++: 
'    ' Eski Foto varsa silme
'    On Error Resume Next
'        Sheets("SEÇ").Shapes("Foto-B9").Delete
'    On Error GoTo 0
bu şekilde değiştiriniz.

Hsn55' Alıntı:
2-Seç sayfasına gelen resmin adı Resim-1 şeklinde olabilir mi?
Genişletmek için tıkla ...
Kodların içinde "Foto-B9" olarak gördüğünüz yerleri "Resim-1" olarak değiştiriniz
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
499
Excel Vers. ve Dili
2010, Türkiye
Hocam bu kodun içerisine

Kod: 
Private Sub UserForm_Initialize()
 Dim X1 As Long, Y1 As Long, Y2 As Long, X2 As Long
    Dim CX As Double, CY As Double
    Dim MyCtrl As Control
    X1 = Application.Width
    Y1 = Application.Height
    X2 = Me.Width
    Y2 = Me.Height
    CX = X1 / X2
    CY = Y1 / Y2
    Me.Width = X1
    Me.Height = Y1
        For Each MyCtrl In Me.Controls
            MyCtrl.Top = MyCtrl.Top * CY
            MyCtrl.Left = MyCtrl.Left * CX
            MyCtrl.Width = MyCtrl.Width * CX
            MyCtrl.Height = MyCtrl.Height * CY
            On Error Resume Next
                MyCtrl.Font.Size = MyCtrl.Font.Size * CY
            On Error GoTo 0
        Next

son = Sheets("GİRİŞLER").Range("b" & Rows.Count).End(3).Row
ComboBox1.RowSource = ""
ComboBox1.RowSource = "GİRİŞLER!b2:b" & son
son = Sheets("GİRİŞLER").Range("c" & Rows.Count).End(3).Row
ComboBox2.RowSource = ""
ComboBox2.RowSource = "GİRİŞLER!c2:c" & son
son = Sheets("GİRİŞLER").Range("d" & Rows.Count).End(3).Row
ComboBox3.RowSource = ""
ComboBox3.RowSource = "GİRİŞLER!d2:d" & son
son = Sheets("GİRİŞLER").Range("e" & Rows.Count).End(3).Row
ComboBox5.RowSource = ""
ComboBox5.RowSource = "GİRİŞLER!e2:e" & son
son = Sheets("GİRİŞLER").Range("e" & Rows.Count).End(3).Row
ComboBox6.RowSource = ""
ComboBox6.RowSource = "GİRİŞLER!e2:e" & son
son = Sheets("GİRİŞLER").Range("e" & Rows.Count).End(3).Row
ComboBox7.RowSource = ""
ComboBox7.RowSource = "GİRİŞLER!e2:e" & son
son = Sheets("GİRİŞLER").Range("f" & Rows.Count).End(3).Row
ComboBox8.RowSource = ""
ComboBox8.RowSource = "GİRİŞLER!f2:f" & son
son = Sheets("GİRİŞLER").Range("f" & Rows.Count).End(3).Row
ComboBox9.RowSource = ""
ComboBox9.RowSource = "GİRİŞLER!f2:f" & son
son = Sheets("GİRİŞLER").Range("f" & Rows.Count).End(3).Row
ComboBox10.RowSource = ""
ComboBox10.RowSource = "GİRİŞLER!f2:f" & son
son = Sheets("GİRİŞLER").Range("G" & Rows.Count).End(3).Row
ComboBox11.RowSource = ""
ComboBox11.RowSource = "GİRİŞLER!G2:G" & son
son = Sheets("GİRİŞLER").Range("M" & Rows.Count).End(3).Row
ComboBox13.RowSource = ""
ComboBox13.RowSource = "GİRİŞLER!M2:M" & son
son = Sheets("GİRİŞLER").Range("B" & Rows.Count).End(3).Row
ComboBox15.RowSource = ""
ComboBox15.RowSource = "GİRİŞLER!B2:B" & son
son = Sheets("GİRİŞLER").Range("C" & Rows.Count).End(3).Row
ComboBox16.RowSource = ""
ComboBox16.RowSource = "GİRİŞLER!C2:C" & son
son = Sheets("GİRİŞLER").Range("D" & Rows.Count).End(3).Row
ComboBox17.RowSource = ""
ComboBox17.RowSource = "GİRİŞLER!D2:D" & son
son = Sheets("GİRİŞLER").Range("D" & Rows.Count).End(3).Row
ComboBox18.RowSource = ""
ComboBox18.RowSource = "GİRİŞLER!D2:D" & son
son = Sheets("GİRİŞLER").Range("J" & Rows.Count).End(3).Row
ComboBox20.RowSource = ""
ComboBox20.RowSource = "GİRİŞLER!J2:J" & son

son = Sheets("GİRİŞLER").Range("K" & Rows.Count).End(3).Row
ComboBox21.RowSource = ""
ComboBox21.RowSource = "GİRİŞLER!K2:K" & son
son = Sheets("GİRİŞLER").Range("I" & Rows.Count).End(3).Row
ComboBox22.RowSource = ""
ComboBox22.RowSource = "GİRİŞLER!I2:I" & son

son = Sheets("GİRİŞLER").Range("L" & Rows.Count).End(3).Row
ComboBox29.RowSource = ""
ComboBox29.RowSource = "GİRİŞLER!L2:L" & son

son = Sheets("GİRİŞLER").Range("E" & Rows.Count).End(3).Row
ComboBox24.RowSource = ""
ComboBox24.RowSource = "GİRİŞLER!E2:E" & son
son = Sheets("GİRİŞLER").Range("E" & Rows.Count).End(3).Row
ComboBox23.RowSource = ""
ComboBox23.RowSource = "GİRİŞLER!E2:E" & son
son = Sheets("GİRİŞLER").Range("E" & Rows.Count).End(3).Row
ComboBox25.RowSource = ""
ComboBox25.RowSource = "GİRİŞLER!E2:E" & son
son = Sheets("GİRİŞLER").Range("F" & Rows.Count).End(3).Row
ComboBox26.RowSource = ""
ComboBox26.RowSource = "GİRİŞLER!F2:F" & son
son = Sheets("GİRİŞLER").Range("F" & Rows.Count).End(3).Row
ComboBox27.RowSource = ""
ComboBox27.RowSource = "GİRİŞLER!F2:F" & son
son = Sheets("GİRİŞLER").Range("F" & Rows.Count).End(3).Row
ComboBox28.RowSource = ""
ComboBox28.RowSource = "GİRİŞLER!F2:F" & son
son = Sheets("GİRİŞLER").Range("N" & Rows.Count).End(3).Row
ComboBox30.RowSource = ""
ComboBox30.RowSource = "GİRİŞLER!N2:N" & son
son = Sheets("GİRİŞLER").Range("O" & Rows.Count).End(3).Row
ComboBox31.RowSource = ""
ComboBox31.RowSource = "GİRİŞLER!O2:O" & son
son = Sheets("GİRİŞLER").Range("P" & Rows.Count).End(3).Row
ComboBox33.RowSource = ""
ComboBox33.RowSource = "GİRİŞLER!P2:P" & son
Set S1 = Worksheets("HARİTA")
Set S2 = Worksheets("AMENAJMAN")
ComboBox15.Value = S1.Range("S2")
ComboBox16.Value = S1.Range("S3")
ComboBox17.Value = S1.Range("S4")
TextBox12.Value = S1.Range("S5")
TextBox13.Value = S1.Range("S8")
ComboBox19.Value = S1.Range("S7")
ComboBox20.Value = S1.Range("BF14")
ComboBox21.Value = S1.Range("H11")
ComboBox22.Value = S1.Range("K47")
ComboBox29.Value = S1.Range("H10")
ComboBox23.Value = S1.Range("H53")
ComboBox24.Value = S1.Range("U53")
ComboBox25.Value = S1.Range("AH53")
ComboBox26.Value = S1.Range("H54")
ComboBox27.Value = S1.Range("U54")
ComboBox28.Value = S1.Range("AH54")
ComboBox30.Value = S2.Range("S2")
ComboBox31.Value = S2.Range("S3")
ComboBox33.Value = S2.Range("S4")
MultiPage1.Value = 0

End Sub
Şu kodu Nasıl ekleriz?
Eklenecek Kod:
Kod: 
Private Sub UserForm_Initialize()
    ' ComboBox1'e öğeler ekleniyor
    With Me.ComboBox1
        .AddItem "Yol"
        .AddItem "Ağaç"
        .AddItem "Tara(Kırmızı)"
        .AddItem "Tara(Mavi)"
        .AddItem "Dolgu Yok (Mavi)"
        .AddItem "Dolgu Yok (Kırmızı)"
        
        ' "Dolgu Yok(Mavi)" varsayılan olarak seçiliyor
        .Value = "Dolgu Yok (Mavi)"
        
        ' Kullanıcının yalnızca listedekileri seçmesini sağla
        .Style = fmStyleDropDownList
    End With
End Sub
 
Biolightant

Biolightant

Katılım
6 Mart 2024
Mesajlar
160
Excel Vers. ve Dili
Excel 2010 TR & Excel 2016 TR
UserForm içinde
"Yol", "Ağaç", "Tara(Kırmızı)" gözükmesini istediğin
ComboBox un ismi(name) nedir ?
 
Biolightant

Biolightant

Katılım
6 Mart 2024
Mesajlar
160
Excel Vers. ve Dili
Excel 2010 TR & Excel 2016 TR
Hsn55' Alıntı:
MultiPage1.Value = 0
Genişletmek için tıkla ...
Bu satırın hemen altına
C++: 
    ' ComboBox48'e öğeler ekleniyor
    With Me.ComboBox48
        .AddItem "Yol"
        .AddItem "Ağaç"
        .AddItem "Tara(Kırmızı)"
        .AddItem "Tara(Mavi)"
        .AddItem "Dolgu Yok (Mavi)"
        .AddItem "Dolgu Yok (Kırmızı)"
        
        ' "Dolgu Yok(Mavi)" varsayılan olarak seçiliyor
        .Value = "Dolgu Yok (Mavi)"
        
        ' Kullanıcının yalnızca listedekileri seçmesini sağla
        .Style = fmStyleDropDownList
    End With
ekleyiniz.
Not: En sonda ki End Sub dursun.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst