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

S

sevensuleyman

Altın Üye
Katılım
9 Kasım 2012
Mesajlar
193
Excel Vers. ve Dili
office 2010
Altın Üyelik Bitiş Tarihi
08-12-2027
mamul koduna göre klasör oluşturup
aynı satırdaki bileşen resimlerini mamul kodunun bulundugu klasör içerisine aktarmak istiyorum.yardımcı olursanız sevinirim
 

Ekli dosyalar

Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,254
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

Resimler masaüstünde oluşturulan "Mamül Resimleri" isimli klasöre aktarılmaktadır.

Umarım sizde de sorun çıkarmadan çalışır.

C++: 
Option Explicit

Sub Mamul_Koduna_Gore_Resimleri_Klasorlere_Aktar()
    Dim Dizi As Object, 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, Ana_Klasor As String, Yol As String, Son As Long
    
    Application.ScreenUpdating = False
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    Set S1 = Sheets("Sheet1")
    
    Ana_Klasor = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & "Mamül Resimleri"
    If Dir(Ana_Klasor, vbDirectory) = "" Then MkDir (Ana_Klasor)
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    Set Alan = S1.Range("B2:B" & Son)
    
    For Each Veri In Alan
        Dizi.Item(Veri.Value) = 1
        
        Yol = Ana_Klasor & Application.PathSeparator & Veri.Value
        
        If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)
            
        Genislik = Veri.Offset(0, 2).Width
        Yukseklik = Veri.Offset(0, 2).Height
            
        For Each Nesne In S1.Shapes
            If Nesne.Type = msoPicture Then
                If Not Intersect(Nesne.TopLeftCell, Veri.Offset(0, 2)) 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.Offset(0, 3).Value & ".jpg", FilterName:="jpg"
                        .Chart.Parent.Delete
                    End With
                
                    Application.DisplayAlerts = True
                End If
            End If
        Next
    Next
    
    Set Dizi = Nothing
    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) & Ana_Klasor
End Sub
 
K

kakara

Altın Üye
Katılım
5 Mart 2014
Mesajlar
252
Excel Vers. ve Dili
excel 2016 plus
Altın Üyelik Bitiş Tarihi
19-12-2025
Korhan üstad yazdıgınız kod sorunsuz çalışıyor.... bu konuyla alakalı oldugu ıcın buraya yazıyorum masa üstündeki mamül resimler klasörune fotograflar klasör klasör degılde dırek gelebılır mı ve fotograf ısımlerı barkod ismi olarak fotograflar da orjınal boyutlarında gelebılır mı ?
 
S

sevensuleyman

Altın Üye
Katılım
9 Kasım 2012
Mesajlar
193
Excel Vers. ve Dili
office 2010
Altın Üyelik Bitiş Tarihi
08-12-2027
resimleri biz excell dosysının içerisinden değil klasörden alacagız

durum farklı anlaşıldı galiba. bileşen orjinal resimleri C:\RESIMABC\Yeni klasör bu dosya yolunda mevcut. excelde yapmış oldugunuz gibi bu klasörden bileşen resimlerini alıp mamulkodu açılan klasörün içerisine aktarmak... çünkü excellde resim kalitesi çok kötü orjinal resimlerimiz var... kusura bakmayın
 
Son düzenleme:
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,254
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
İşte sorularınızı açık ve net bir dille sorun derken tam olarak bunu kastediyoruz.

Şimdi kodlamayı yeniden yazmak gerekecek...
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,254
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
@kakara,

Bahsettiğiniz işlemler elbette yapılabilir. Bu yönde örnek dosyanızı paylaşırsanız kodları ona göre revize edebiliriz. Yalnız resimler ilgili satırdaki boyutlarına göre dışarı aktarılıyor. Orjinal boyut konusunda ne yapılabilir açıkçası tam olarak aklıma şuan bir fikir gelmedi.
 
K

kakara

Altın Üye
Katılım
5 Mart 2014
Mesajlar
252
Excel Vers. ve Dili
excel 2016 plus
Altın Üyelik Bitiş Tarihi
19-12-2025
@Korhan Ayhan

üstad örnek dosyayı paylaşıyorum tabı konu sahıbı arkadaşımın işi daha acil olabılır siz musait bır zamanında bakabılırsenız sevınırım.
 

Ekli dosyalar

Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,254
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Boş dosya yerine en azından bir barkod ve resim paylaşsaydınız iyi olurdu.
 
S

sevensuleyman

Altın Üye
Katılım
9 Kasım 2012
Mesajlar
193
Excel Vers. ve Dili
office 2010
Altın Üyelik Bitiş Tarihi
08-12-2027
sütunundaki verilere göre klasör oluşup [E] sütunundaki kodlu ürün göre kaynak klasörünün içerinden bileşen koduna göre ilgili resmi bulup b sütununda oluşan klasörün içerisine gruplanacak. kaynak klasör ve istenilen klasör dosya ekinde mevcuttur... ilginiz için tşk
 

Ekli dosyalar

Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,254
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
@kakara,

Deneyiniz.

C++: 
Option Explicit

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 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
 
S

sevensuleyman

Altın Üye
Katılım
9 Kasım 2012
Mesajlar
193
Excel Vers. ve Dili
office 2010
Altın Üyelik Bitiş Tarihi
08-12-2027
Korhan Ayhan' Alıntı:
@kakara,

Deneyiniz.

C++: 
Option Explicit

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 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
Genişletmek için tıkla ...
219999
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,254
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Kod diğer arkadaş içindi...

Sizin için hazırlıyorum...
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,254
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
@SeviLmeyen,

KAYNAK KLASÖR'ünüz bu makroyu kullanacağınız dosya ile aynı bölümde olsun. Ya da Aranan_Klasor yolunu kendinize göre düzenleyiniz.

C++: 
Option Explicit

Sub Mamul_Koduna_Gore_Resimleri_Klasorlere_Aktar()
    Dim Dizi As Object, Alan As Range, Veri As Range, S1 As Worksheet, Resim As Object
    Dim XL_Chart As Object, Son As Long, Aranan_Klasor As String, Aranan_Resim As String
    Dim Nesne As Shape, Ana_Klasor As String, Yol As String
    
    Application.ScreenUpdating = False
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    Set S1 = Sheets("Sheet1")
    
    Ana_Klasor = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & "Mamül Resimleri"
    If Dir(Ana_Klasor, vbDirectory) = "" Then MkDir (Ana_Klasor)
    
    Aranan_Klasor = ThisWorkbook.Path & Application.PathSeparator & "KAYNAK KLASÖR" & Application.PathSeparator
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    Set Alan = S1.Range("B2:B" & Son)
    
    For Each Veri In Alan
        Dizi.Item(Veri.Value) = 1
        
        Yol = Ana_Klasor & Application.PathSeparator & Veri.Value
        
        If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)
                    
        Aranan_Resim = Aranan_Klasor & Veri.Offset(0, 3).Value & ".jpg"
        
        If Dir(Aranan_Resim) <> "" Then
            FileCopy Aranan_Resim, Yol & Application.PathSeparator & Veri.Offset(0, 3).Value & ".jpg"
        End If
    Next
    
    Set Dizi = Nothing
    Set S1 = Nothing
    Set Alan = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Mamül resimleri aşağıdaki klasöre başarıyla kayıt edilmiştir." & Chr(10) & Chr(10) & Ana_Klasor
End Sub
 
S

sevensuleyman

Altın Üye
Katılım
9 Kasım 2012
Mesajlar
193
Excel Vers. ve Dili
office 2010
Altın Üyelik Bitiş Tarihi
08-12-2027
Korhan Ayhan' Alıntı:
@SeviLmeyen,

KAYNAK KLASÖR'ünüz bu makroyu kullanacağınız dosya ile aynı bölümde olsun. Ya da Aranan_Klasor yolunu kendinize göre düzenleyiniz.

C++: 
Option Explicit

Sub Mamul_Koduna_Gore_Resimleri_Klasorlere_Aktar()
    Dim Dizi As Object, Alan As Range, Veri As Range, S1 As Worksheet, Resim As Object
    Dim XL_Chart As Object, Son As Long, Aranan_Klasor As String, Aranan_Resim As String
    Dim Nesne As Shape, Ana_Klasor As String, Yol As String
   
    Application.ScreenUpdating = False
   
    Set Dizi = CreateObject("Scripting.Dictionary")
    Set S1 = Sheets("Sheet1")
   
    Ana_Klasor = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & "Mamül Resimleri"
    If Dir(Ana_Klasor, vbDirectory) = "" Then MkDir (Ana_Klasor)
   
    Aranan_Klasor = ThisWorkbook.Path & Application.PathSeparator & "KAYNAK KLASÖR" & Application.PathSeparator
   
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    Set Alan = S1.Range("B2:B" & Son)
   
    For Each Veri In Alan
        Dizi.Item(Veri.Value) = 1
       
        Yol = Ana_Klasor & Application.PathSeparator & Veri.Value
       
        If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)
                   
        Aranan_Resim = Aranan_Klasor & Veri.Offset(0, 3).Value & ".jpg"
       
        If Dir(Aranan_Resim) <> "" Then
            FileCopy Aranan_Resim, Yol & Application.PathSeparator & Veri.Offset(0, 3).Value & ".jpg"
        End If
    Next
   
    Set Dizi = Nothing
    Set S1 = Nothing
    Set Alan = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "Mamül resimleri aşağıdaki klasöre başarıyla kayıt edilmiştir." & Chr(10) & Chr(10) & Ana_Klasor
End Sub
Genişletmek için tıkla ...
Söylediğiniz gibi excell dosyamı kayank klasörüme içerisnne ekleyip çalıştırdım. klasörler oluşuyor.fakat resimler kopyalanmıyor.
 
K

kakara

Altın Üye
Katılım
5 Mart 2014
Mesajlar
252
Excel Vers. ve Dili
excel 2016 plus
Altın Üyelik Bitiş Tarihi
19-12-2025
@Korhan Ayhan verdıgınız kod çalışıyor gıbı gozukuyor ama exceldekı fotografları masa ustundekı Mamül Resimleri klasörune kopyalamıyor.

C++:
Option Explicit

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 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
 

Ekli dosyalar

S

SeviLmeyen

Katılım
6 Mayıs 2020
Mesajlar
205
Excel Vers. ve Dili
Microsoft Office 365 E3
Altın Üyelik Bitiş Tarihi
01-10-2024
Korhan Ayhan' Alıntı:
@SeviLmeyen,

KAYNAK KLASÖR'ünüz bu makroyu kullanacağınız dosya ile aynı bölümde olsun. Ya da Aranan_Klasor yolunu kendinize göre düzenleyiniz.

C++: 
Option Explicit

Sub Mamul_Koduna_Gore_Resimleri_Klasorlere_Aktar()
    Dim Dizi As Object, Alan As Range, Veri As Range, S1 As Worksheet, Resim As Object
    Dim XL_Chart As Object, Son As Long, Aranan_Klasor As String, Aranan_Resim As String
    Dim Nesne As Shape, Ana_Klasor As String, Yol As String
   
    Application.ScreenUpdating = False
   
    Set Dizi = CreateObject("Scripting.Dictionary")
    Set S1 = Sheets("Sheet1")
   
    Ana_Klasor = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & "Mamül Resimleri"
    If Dir(Ana_Klasor, vbDirectory) = "" Then MkDir (Ana_Klasor)
   
    Aranan_Klasor = ThisWorkbook.Path & Application.PathSeparator & "KAYNAK KLASÖR" & Application.PathSeparator
   
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    Set Alan = S1.Range("B2:B" & Son)
   
    For Each Veri In Alan
        Dizi.Item(Veri.Value) = 1
       
        Yol = Ana_Klasor & Application.PathSeparator & Veri.Value
       
        If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)
                   
        Aranan_Resim = Aranan_Klasor & Veri.Offset(0, 3).Value & ".jpg"
       
        If Dir(Aranan_Resim) <> "" Then
            FileCopy Aranan_Resim, Yol & Application.PathSeparator & Veri.Offset(0, 3).Value & ".jpg"
        End If
    Next
   
    Set Dizi = Nothing
    Set S1 = Nothing
    Set Alan = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "Mamül resimleri aşağıdaki klasöre başarıyla kayıt edilmiştir." & Chr(10) & Chr(10) & Ana_Klasor
End Sub
Genişletmek için tıkla ...
Korhan Bey,
Sanırım karıştırdınız ya da ben karıştırdım.
Resimle ilgili bir isteğim yoktu benim Sanırım sevensuleymana yazacaktınız.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst