Hücre içine resmi ortalama

hamza02 · Çarşamba saat 19:53'de

İndir Evrak Alma Verme Yetki Kartı xlsm

Dosyayı indir Evrak Alma Verme Yetki Kartı xlsm

dosya.co

Arkadaşlar merhaba,

Linkini eklediğim dosyada,
1-Resmi hücre içine yatay ve dikey ortalamak
2-Resmin belirtilen hücre dışına taşmamasını sağlamak
3-Sadece jpg değil diğer resim dosyalarınıda desteklesin
4-Belirtilen sicile ait resim yoksa işleme devam etsin

Ben uğraştım bu işlemleri yapamadım yardımcı olursanız sevinirim.

Biolightant · Perşembe saat 10:10'de

Merhaba,

C++:

Private Sub ComboBox1_Change()
    
        Dim Resim As Shape
        Dim Hucre As Range

        On Error Resume Next
        Set Hucre = Range("E5:E10")
        On Error GoTo 0
        
        If Hucre Is Nothing Then Exit Sub
        
        For Each Resim In ActiveSheet.Shapes
            If Not Intersect(Resim.TopLeftCell, Hucre) Is Nothing Then
                If Resim.Type = msoPicture Or Resim.Type = msoLinkedPicture Then
                    Resim.Delete
                End If
            End If
        Next Resim
 
    Sayfa1.Range("P14").Value = ComboBox1.Text          ' ComboBox ile Seçilen Suç Numarasını yazar
        
    Sayfa1.Range("D5") = ": " & WorksheetFunction.VLookup(Sayfa1.Range("P14"), Sayfa2.Range("B2:H50"), 4, 0)  'D5 hücresine ... yazar
    Sayfa1.Range("D6") = ": " & WorksheetFunction.VLookup(Sayfa1.Range("P14"), Sayfa2.Range("B2:H50"), 3, 0)  'D6 hücresine ... yazar
    Sayfa1.Range("D7") = ": " & WorksheetFunction.VLookup(Sayfa1.Range("P14"), Sayfa2.Range("B2:H50"), 5, 0)  'D7 hücresine ... yazar
    Sayfa1.Range("D8") = ": " & WorksheetFunction.VLookup(Sayfa1.Range("P14"), Sayfa2.Range("B2:H50"), 2, 0) & " / " & Sayfa1.Range("P14")
    Sayfa1.Range("D9") = ": " & WorksheetFunction.VLookup(Sayfa1.Range("P14"), Sayfa2.Range("B2:H50"), 6, 0)
    
    Sayfa1.Range("K9") = WorksheetFunction.VLookup(Sayfa1.Range("P14"), Sayfa2.Range("B2:H50"), 6, 0)

    Range("D9").NumberFormat = ": dd.mm.yyyy"

    'dosya = ActiveWorkbook.Path & "\RESIMLER\" & Sayfa2.Cells(2, 2).Value & ".jpg"      'parantez içi 2.satırı, 2.sütunu ifade eder

    Sayfa1.Cells(5, 5).Select
    
    '***** YENİ KODLAR *****
    
    Dim ws As Worksheet
    Dim fotoPath As String
    
    Set ws = Sayfa1
    
    fotoPath = ResimYolunuBul(ThisWorkbook.Path & "\Foto\", Sayfa1.Cells(14, 16).Value)
    
    If fotoPath = "" Then
        MsgBox "Resim bulunamadı: " & Sayfa1.Cells(14, 16).Value, vbExclamation
        Exit Sub
    End If
    
    ResmiEkle ws, ws.Range("E5:E9"), fotoPath
    
    Sayfa1.Range("A1").Select

End Sub

Private Function ResimYolunuBul(klasor As String, dosyaAdi As String) As String

    Dim uzanti As Variant
    Dim tamYol As String
    
    dosyaAdi = Trim(dosyaAdi)
    
    If dosyaAdi = "" Then Exit Function
    
    For Each uzanti In Array("jpg", "jpeg", "png", "bmp", "gif", "tif", "tiff")
        
        tamYol = klasor & dosyaAdi & "." & uzanti
        
        If Dir(tamYol) <> "" Then
            ResimYolunuBul = tamYol
            Exit Function
        End If
        
    Next uzanti

End Function

Private Sub ResmiEkle(ws As Worksheet, hedef As Range, FilePath As String)

    Dim shp As Shape
    
    Set shp = ws.Shapes.AddPicture( _
        FilePath, _
        msoFalse, _
        msoTrue, _
        hedef.Left, _
        hedef.Top, _
        -1, _
        -1 _
    )
    
    shp.Name = "Resim_" & Format(Now, "hhmmss")
    
    ResmiHucreyeSigdir shp, hedef

End Sub
Private Sub ResmiHucreyeSigdir(shp As Shape, hedef As Range)

    Dim oranW As Double
    Dim oranH As Double
    Dim oran As Double
    Dim bosluk As Double
    
    bosluk = 10
    
    shp.LockAspectRatio = msoTrue
    
    oranW = (hedef.Width - bosluk) / shp.Width
    oranH = (hedef.Height - bosluk) / shp.Height
    
    If oranW < oranH Then
        oran = oranW
    Else
        oran = oranH
    End If
    
    shp.Width = shp.Width * oran
    
    shp.Left = hedef.Left + (hedef.Width - shp.Width) / 2
    shp.Top = hedef.Top + (hedef.Height - shp.Height) / 2
    
    shp.Placement = xlMoveAndSize

End Sub

hamza02 · Cuma saat 19:56'de

Sayın Biolightant hocam eline emeğine sağlık çok güzel olmuş. Çok teşekkür ederim.

hamza02 · Cuma saat 19:59'de

Hocam D9 ve K9 hücrelerine tarih çekiyorum. Hücreye sadece tarih çekince sorun yok, ama tarihin önüne ":" iki nokta koyunca tarih formatından çıkıyor. Bunun için kodda nasıl bir değişiklik yapmam lazım.

Biolightant · Cuma saat 20:54'de

Merhaba,

Sayfa1.Range("D9") = ": " & WorksheetFunction.VLookup(Sayfa1.Range("P14"), Sayfa2.Range("B2:H50"), 6, 0)

yukarıdaki yazdığım satırı, aşağıda yazığım ile değiştirip kontrol edermisin

Sayfa1.Range("D9") = ": " & Format(WorksheetFunction.VLookup(Sayfa1.Range("P14"), Sayfa2.Range("B2:H50"), 6, 0), "dd.mm.yyyy")

hamza02 · Cuma saat 21:24'de

Harika hocam.
Çok teşekkür ederim.

hamza02 · Bugün 13:51

İndir Evrak Alma Verme Yetki Kartı xlsm

Dosyayı indir Evrak Alma Verme Yetki Kartı xlsm

dosya.co

Değerli arkadaşlar linkini eklediğim dosyada Checkbox butonuna tıklayınca (işaretli olunca) Sayfa2 nin 8.sütununa "Evet" yazmasını, tekrar tıklayınca "Hayır" yazmasını yapamadım.
Yardımcı olur musunuz.
Şimdiden teşekkür ederim.

Biolightant · 32 dakika önce

Merhaba,
Sorunuzda çok bilinmeyen var...

C++:

Private Sub CheckBox1_Click()

    Dim aranan As String
    Dim bul As Range
    
    If Me.CheckBox1.Value = False Then Exit Sub
    
    aranan = Trim(Me.Range("P14").Value)
    
    If aranan = "" Then Exit Sub
    
    Set bul = Sayfa2.Columns("B").Find( _
        What:=aranan, _
        LookIn:=xlValues, _
        LookAt:=xlWhole _
    )
    
    If bul Is Nothing Then
        MsgBox "Veri sayfasında bulunamadı: " & aranan, vbExclamation
        Exit Sub
    End If
    
    Sayfa2.Cells(bul.Row, "H").Value = "Evet"

End Sub