klasör oluştur dosyaları klasör klasör grupla

[Korhan Ayhan]

@kakara,

Aşağıdaki kodu deneyiniz.

Sub Mamul_Koduna_Gore_Resimleri_Klasorlere_Aktar()
    Dim Alan As Range, Veri As Range, S1 As Worksheet, Resim As Object
    Dim XL_Chart As Object, Genislik As Integer, Yukseklik As Integer
    Dim Nesne As Shape, Yol As String, Son As Long
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa1")
    
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & "Mamül Resimleri"
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Set Alan = S1.Range("A2:A" & Son)
    
    For Each Veri In Alan
        Genislik = Veri.Offset(0, 1).Width
        Yukseklik = Veri.Offset(0, 1).Height
            
        For Each Nesne In S1.Shapes
            If Nesne.Type = msoPicture Or Nesne.Type = msoLinkedPicture Then
                If Not Intersect(Nesne.TopLeftCell, Veri.Offset(0, 1)) Is Nothing Then
                    Nesne.CopyPicture
                    
                    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 & Application.PathSeparator & _
                                                Veri.Value & ".jpg", FilterName:="jpg"
                        .Chart.Parent.Delete
                    End With
                
                    Application.DisplayAlerts = True
                End If
            End If
        Next
    Next
    
    Set S1 = Nothing
    Set Alan = Nothing
    Set XL_Chart = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Mamül resimleri aşağıdaki klasöre başarıyla kayıt edilmiştir." & Chr(10) & Chr(10) & Yol
End Sub

 

[kakara]

@Korhan Ayhan ustad kod calısıyor yalnız benım hatamdan dolay sanırım (sıze verdıgım ornekte tek fotograf vardı ) tek bır fotograf atıyor ben a sutununda alt alta yazan barkodların karşılıkları olan tum fotografları klasöre aktarmak ıstıyorum acaba kodda nereyı degıstırıcegımı soylıyebılır mısnız ? tesekkurler

 

[Korhan Ayhan]

Kod zaten sizin bahsettiğiniz şekilde çalışıyor olması gerekiyor.

 

[kakara]

@Korhan Ayhan ustad malesef bahsettıgım gıbı calısmıyor arada bazı fotografları cekmıyor daha fazla foto olan örnegı eklıyorum musaıt oldugunuzda bakabılırsenız sevınırım ( daha fazla foto koyucaktım fakat yuklenmedıgı ıcın az foto ekledım )

 

[Korhan Ayhan]

Dosyanızda 1. resim ile 2. resim üst üste gelmiş görünüyor. Bu sebeple TopLeftCell değerleri karışıyor.

Resimlerinizi B sütunundaki hücrelerde tam sıfıra sıfır değilde birazcık kenarlardan boşluk olacak şekilde yerleştirme durumunuz varsa sorun çözülecektir.

 

[kakara]

tesekkurler @Korhan Ayhan