Excel'de Her Hücreyi (Hücrelerde Sadece Metin Var) Resim Olarak Farklı Kaydetme

[birkan_morkoc]

Merhabalar Excel de A sütunundaki her satırı bir klasör açıp sonra B,C,D,E sütunlardaki satırları resim olarak nasıl kaydedebilirim yani birinci satırda ilk hücreyi klasör açıp sonra yanındaki hücreleri jpg olarak (300*217px) nasıl kaydedebilirim.

Sorunu kısaltmak gerekirse klasör olayını atlayıp. Her hücreyi nasıl jpg (300*217px) olarak kaydedebilirim

Örnek ; https://hizliresim.com/lAdhzz

 

[Saban Sertkaya]

Merhabalar,
Foruma hoşgeldiniz.
Foruma yeni mesajlar geldikçe sizin mesajınız aşağıda kalmakta ve görüntü ekranından çıkmaktadır. Konunun güncel kalabilmesi için, ara ara açmış olduğunuz bu konuya "Günceldir" gibi bir mesaj atınız. Yardımcı olacak birileri mutlaka çıkacaktır.

Ben yardımcı olamadığım için kusura bakmayın.

 

[Saban Sertkaya]

birkan_morkoc için günceldir.

 

[Korhan Ayhan]

Deneyiniz.

Klasör masaüstünde RESİMLER adındaki klasör altında oluşturulur. Bu klasör masaüstünde yoksa kod onu da otomatik olarak oluşturur.

Yalnız resimlerin pixel ayarını sanıryorum başka program ile ayarlamanız gerekecek.

Option Explicit

Sub Hucreleri_Resim_Olarak_Klasorlere_Aktar()
    Dim Alan As Range, Klasor As Range, Veri As Range, S1 As Worksheet
    Dim Resim As Object, Seperator As String, Yol As String, Son As Long
    Dim XL_Chart As Object, Genislik As Integer, Yukseklik As Integer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sheet1")
    
    Seperator = Application.PathSeparator
    
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Seperator & "Resimler"
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Set Alan = S1.Range("A3:A" & Son)
    
    For Each Klasor In Alan
        If Dir(Yol & Seperator & Klasor, vbDirectory) = "" Then
            MkDir (Yol & Seperator & Klasor)
        End If
            
        For Each Veri In S1.Range("B" & Klasor.Row & ":E" & Klasor.Row)
            If Veri.Value <> "" Then
                Genislik = Veri.Width * 10
                Yukseklik = Veri.Height * 10
                    
                Veri.CopyPicture xlScreen, xlPicture
                
                Application.DisplayAlerts = False
            
                Set XL_Chart = S1.ChartObjects.Add(0, 0, Genislik, Yukseklik)
                
                With XL_Chart
                    .Chart.Parent.Activate
                    .Chart.Parent.Border.LineStyle = 0
                    .Chart.Paste
                     DoEvents
                     Set Resim = ActiveChart.Shapes.Range(Array("chart"))
                     With Resim
                        .Width = Genislik
                        .Height = Yukseklik
                     End With
                    .Chart.Export Filename:=Yol & Seperator & Klasor & Seperator & _
                                            Veri.Value & ".jpg", FilterName:="jpg"
                    .Chart.Parent.Delete
                End With
    
                Application.DisplayAlerts = True
            End If
        Next
    Next
    
    Set S1 = Nothing
    Set Alan = Nothing
    Set XL_Chart = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Resimler aşağıdaki klasöre başarıyla kayıt edilmiştir." & vbLf & vbLf & Yol
End Sub