excel sütündaki resimleri ürün kodu ismiyle kaydetme

[ehlikeyf12]

excelde a sütündaki resimleri b sütünündaki ürün kodu baz alınarak dosyaya kaydetmek istiyorum.
yardımcı olabilirmisiniz.
şimdiden teşekkürler

 

[BedriA]

Biraz daha açabilir misiniz?
B sütunu baz alınarak A sütununa ürün resmi mi almak istiyorsunuz?
Bir nevi katalog yani...

 

[ehlikeyf12]

şöyleki 500 tane fln fotoğraf var a sütünda, b sutunundada fotograflara ait ürün kodları var. ben bu resimleri isimleri ürün kodu olacak şekilde dosyaya kaydetmek istiyorum. bilmem becerebildimmi anlatmayı

 

[BedriA]

Dosyaya derken, yeni klasöre diyorsunuz sanırım.
Bu beşyüz fotoğraf excel dışında bir klasörde mevcut mu peki?

 

[ehlikeyf12]

evet yeni klasörü kast etmiştim.
Bu beşyüz fotoğraf excel dışında bir klasörde mevcut mu peki? hayır excelde

 

[BedriA]

Resimlerin tamamı A hücrelerinde mi? Taşma falan yok yani...

 

[ehlikeyf12]

Resimlerin tamamı A hücrelerinde mi? Taşma falan yok yani...

tamamen hücreye oturuyor taşma yok

 

[BedriA]

Aşağıdaki kodu bir deneyin.
Masa üstüne Resim diye bir klasör açın.
Kod çalışırsa resimleri bu klasöre B deki isimlerle kaydeder.
Kodu denemedim, bir deneyin.

Sub KOD()
    
    Dim rng As Range, cht As ChartObject, say As Double, obj As Object
    Const strPath As String = "C:\Destkop\Resim\"
    
    Application.ScreenUpdating = False
    
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        
        Set obj = CreateObject("Scripting.FileSystemObject").GetFolder(strPath)
        say = obj.Files.Count + 1
        
        Set rng = Range(Cells(i, "A")
        
        rng.CopyPicture xlScreen, xlPicture
        Set cht = ActiveSheet.ChartObjects.Add(0, 0, rng.Width + 0, rng.Height + 0)
        cht.Border.LineStyle = 0
        cht.Chart.Paste
        cht.Chart.Export strPath & "" & Range(Cells(i, "B").Value & ".jpg"
        cht.Delete
        
ExitProc:
        
    Next i
    Set obj = Nothing: Set rng = Nothing: Set cht = Nothing
    Application.ScreenUpdating = True
    
End Sub

 

[BedriA]

Olmazsa şu linke bir göz atın.
Yukarıdaki kodu da ordan alıp uyarlamaya çalıştım.

Tıklayın

 

[ehlikeyf12]

denedim şimdi
compile error
expected : list separator or diye uyarı verdi


resim diye klasör actım bu arada masa üstüne

Aşağıdaki kodu bir deneyin.
Masa üstüne Resim diye bir klasör açın.
Kod çalışırsa resimleri bu klasöre B deki isimlerle kaydeder.
Kodu denemedim, bir deneyin.

Sub KOD()
    
    Dim rng As Range, cht As ChartObject, say As Double, obj As Object
    Const strPath As String = "C:\Destkop\Resim\"
    
    Application.ScreenUpdating = False
    
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        
        Set obj = CreateObject("Scripting.FileSystemObject").GetFolder(strPath)
        say = obj.Files.Count + 1
        
        Set rng = Range(Cells(i, "A")
        
        rng.CopyPicture xlScreen, xlPicture
        Set cht = ActiveSheet.ChartObjects.Add(0, 0, rng.Width + 0, rng.Height + 0)
        cht.Border.LineStyle = 0
        cht.Chart.Paste
        cht.Chart.Export strPath & "" & Range(Cells(i, "B").Value & ".jpg"
        cht.Delete
        
ExitProc:
        
    Next i
    Set obj = Nothing: Set rng = Nothing: Set cht = Nothing
    Application.ScreenUpdating = True
    
End Sub

 

[ehlikeyf12]

Olmazsa şu linke bir göz atın.
Yukarıdaki kodu da ordan alıp uyarlamaya çalıştım.

Tıklayın

şöyle bişede var exceli birlikte aç yapıp ziple açtım içindeki resimlerin uzantısını emf olarak gördüm işe yarar bilgimidir bilemedim paylaşmak istedim

 

[ehlikeyf12]

dilersen dosyayıda paylaşabilirim daha iyi görmek açısından

 

[BedriA]

Bir yöntem buldum galiba.

Sayfanızdan bir ekran görüntüsü paylaşmanız mümkün mü?

 

[BedriA]

dilersen dosyayıda paylaşabilirim daha iyi görmek açısından

500 fotoğraflı dosya yüklü olur şimdi.

 

[ehlikeyf12]

https://i.hizliresim.com/7Np1Jl.png

azaltabilirim 100 tane fln maksat yapılabilirliğini görmek

 

[BedriA]

Öncelikle dosyanızın yedeğini mutlaka alın.

C diskinin içinde Resim adıyla bir klasör açın.

Şu kodu sayfa1'in kod alanına yapıştırın.

Private Sub Worksheet_Activate()
 Range("C1").Select
ActiveCell.FormulaR1C1 = "=COUNTA(RC[-1]:R[499]C[-1])"

Call resimal
End Sub

Boş bir modül açarak içine aşağıdaki kodları olduğu gibi kopyalayın.

Sub KOD()
    
    Dim rng As Range, cht As ChartObject, say As Double, obj As Object
    Const strPath As String = "C:\Resim\"
    
    Application.ScreenUpdating = False
    
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        
        Set obj = CreateObject("Scripting.FileSystemObject").GetFolder(strPath)
        say = obj.Files.Count + 1
        
        Set rng = Range(Cells(i, "A"), Cells(i, "A"))
        
        rng.CopyPicture xlScreen, xlPicture
        Set cht = ActiveSheet.ChartObjects.Add(0, 0, rng.Width + 0, rng.Height + 0)
        cht.Border.LineStyle = 0
        cht.Chart.Paste
        cht.Chart.Export strPath & "" & Range("b" & i) & ".jpg"
        cht.Delete
        
ExitProc:
        
    Next i
    Set obj = Nothing: Set rng = Nothing: Set cht = Nothing
    Application.ScreenUpdating = True
    
    Call sil
End Sub


Sub sil()

 ActiveSheet.Range("A1").Select
 Selection.EntireRow.Delete
 Sheets("sayfa2").Select
  Sheets("sayfa1").Select
 
End Sub

Sub resimal()

If ActiveSheet.Range("C1").Value <> 0 Then
Call KOD
Call sil
End If

End Sub

Ardında önce sayfa2'ye, sonra da sayfa1'e tıklayın.

Bende çalıştı kodlar.