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

sevensuleyman · 23 Temmuz 2020

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

sevensuleyman · 23 Temmuz 2020

GÜNCEL

Korhan Ayhan · 23 Temmuz 2020

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

kakara · 23 Temmuz 2020

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

sevensuleyman · 23 Temmuz 2020

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

Korhan Ayhan · 23 Temmuz 2020

İşte sorularınızı açık ve net bir dille sorun derken tam olarak bunu kastediyoruz.

Şimdi kodlamayı yeniden yazmak gerekecek...

Korhan Ayhan · 23 Temmuz 2020

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

kakara · 23 Temmuz 2020

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

Korhan Ayhan · 23 Temmuz 2020

Boş dosya yerine en azından bir barkod ve resim paylaşsaydınız iyi olurdu.

sevensuleyman · 23 Temmuz 2020

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

Korhan Ayhan · 23 Temmuz 2020

@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

sevensuleyman · 23 Temmuz 2020

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

Korhan Ayhan · 23 Temmuz 2020

Kod diğer arkadaş içindi...

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

Korhan Ayhan · 23 Temmuz 2020

@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

sevensuleyman · 23 Temmuz 2020

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

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.

Korhan Ayhan · 23 Temmuz 2020

Bende kopyalanıyor.

sevensuleyman · 23 Temmuz 2020

Korhan Ayhan' Alıntı:
Bende kopyalanıyor.

daha önce Mamül Resimleri adlı klasör kayıtlı duyordu. silip tekrar çalıştırdıgımda düzeldi. çok teşekkür ederim .sorunsuz çalışıyor

kakara · 24 Temmuz 2020

@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

SeviLmeyen · 24 Temmuz 2020

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

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.

Korhan Ayhan · 24 Temmuz 2020

Haklısınız... Özür dilerim.

İsimler benzer olunca karıştırdık...

@sevensuleyman
@SeviLmeyen

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

sevensuleyman

Ekli dosyalar

sevensuleyman

Korhan Ayhan

Administrator

kakara

sevensuleyman

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

kakara

Ekli dosyalar

Korhan Ayhan

Administrator

sevensuleyman

Ekli dosyalar

Korhan Ayhan

Administrator

sevensuleyman

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

sevensuleyman

Korhan Ayhan

Administrator

sevensuleyman

kakara

Ekli dosyalar

SeviLmeyen

Korhan Ayhan

Administrator