Klasör isim değiştirme,kopyalama,taşıma Makro Çalışması

yasin85 · 30 Mart 2019

Merhabalar,

Ekli dosyada yapılması gerekenleri aşağıda detaylarını yazdığım gibi işlemleri yapa bilecek bir makro çalışmasına ihtiyacımız vardır.
Buton ekleye bilinirse çok daha kolay olur bizler için..
Yardımlarınızı bekliyoruz.

İSİMLER = Kaynak klasör yolunu gösterip o yolun içerisinde bulunan dosya isimlerini getirmek içindir.

İSİM DEĞİŞTİRME = Kaynak klasörde bulunan dosya isimlerini getirir ve değiştirilmesini istediklerimiz kalır ( DOSYA ADI ESKİ ) ve değişmesini istediklerimizin ( DOSYA ADI YENİ) istediklerimizi yazıp değiştirmek içindir.

KOPYALA = Kaynak klasörde bulunan dosya isimlerini getirir ve hedef klasöre kopyalanmasını istediklerimizi tutarız kalanının isimleri silinir ve kopyalama işlemi yapılır.

TAŞIMA = Kaynak klasörde bulunan dosya isimlerini getirir ve hedef klasöre taşımasını istediklerimizi tutarız kalanının isimleri silinir ve taşıma işlemi yapılır.

http://www.dosya.tc/server17/mn9tu5/klasor_isim_degistirme_kopyalama_tasima.rar.html

halit3 · 30 Mart 2019

Alternatif dosya ekliyorum.

Asri · 30 Mart 2019

Alternatif ;

Tek safya kullanıldı.

İsimler sayfası kod bölümü için

Kod:

Sub kaynaksec()
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Kaynak klasörü seçiniz."
    .AllowMultiSelect = False
    .InitialFileName = ActiveWorkbook.Path
     If .Show <> -1 Then GoTo NextCode
     Application.EnableEvents = False
     Range("A2").Value = .SelectedItems(1)
     Application.EnableEvents = True
End With
 
 
NextCode:
Set fldr = Nothing
End Sub

Sub hedefsec()
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Hedef klasörü seçiniz."
    .AllowMultiSelect = False
    .InitialFileName = ActiveWorkbook.Path
     If .Show <> -1 Then GoTo NextCode
     Application.EnableEvents = False
     Range("B2").Value = .SelectedItems(1)
     Application.EnableEvents = True
End With

NextCode:
Set fldr = Nothing
End Sub

Sub hedeflistele()
    dosya = Dir(Range("B2").Value & "\*.*")
    sat = 2
    Do While dosya <> ""
      sat = sat + 1
      Cells(sat, "B").Value = dosya
      dosya = Dir
    Loop
    Range("C2").Select
End Sub

Sub kaynaklistele()
   dosya = Dir(Range("A2").Value & "\*.*")
    sat = 2
    Do While dosya <> ""
    sat = sat + 1
    Cells(sat, "A").Value = dosya
    dosya = Dir
    Loop
    Range("C2").Select
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
     If Intersect(Target, Range("A2")) Is Nothing Then GoTo devam
        Call kaynaksec
        sonsatir = Cells(Rows.Count, "A").End(3).Row + 5
        Range("A3:A" & sonsatir).Clear
        
        Call kaynaklistele
        
        sonsatir = Cells(Rows.Count, "B").End(3).Row + 5
        Range("B3:B" & sonsatir).Clear
        Call hedeflistele
        
        Exit Sub
devam:
        If Intersect(Target, Range("B2")) Is Nothing Then GoTo devam2
        Call hedefsec
        sonsatir = Cells(Rows.Count, "B").End(3).Row + 5
        Range("B3:B" & sonsatir).Clear
        Call hedeflistele
        sonsatir = Cells(Rows.Count, "A").End(3).Row + 5
        Range("A3:A" & sonsatir).Clear
        Call kaynaklistele
        Exit Sub
devam2:
End Sub

Modül 1 için

Kod:

'Asri Akdeniz - www.asriakdeniz.com - asriakdeniz@gmail.com
Sub tasi()
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    On Error GoTo son
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    yeniklasor = Range("B2").Value
    For i = 3 To sonsatir
        kaynakisim = Range("A2").Value & "\" & Range("A" & i).Value
        If dosyavarmi(kaynakisim) Then
            hedefisim = yeniklasor & "\" & Range("A" & i).Value
            FSO.MoveFile Source:=kaynakisim, Destination:=hedefisim
            Range("B" & i).Value = Range("A" & i).Value
            Range("A" & i).Value = ""
            Range("E" & i).Value = ""
            GoTo atla
        Else
            Range("E" & i).Value = "Dosya Yok"
            GoTo atla
        End If
son:
        Range("E" & i).Value = "Taşınamadı"
atla:
    Next i
    Set FSO = Nothing
    MsgBox ("Dosya taşıma işlemi tamamlandı.")
End Sub

Sub Kopyala()
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

    sonsatir = Cells(Rows.Count, "A").End(3).Row
    yeniklasor = Range("B2").Value
    For i = 3 To sonsatir

        kaynakisim = Range("A2").Value & "\" & Range("A" & i).Value
        If dosyavarmi(kaynakisim) Then
            hedefisim = yeniklasor & "\" & Range("A" & i).Value
            On Error GoTo son
            FSO.CopyFile "" & kaynakisim & "", "" & hedefisim & ""
            Range("F" & i).Value = ""
            GoTo atla
        Else
            Range("F" & i).Value = "Dosya Yok"
            GoTo atla
        End If
son:
        Range("F" & i).Value = "Kopyalanmadı"
atla:
    Next i
    Set FSO = Nothing
     MsgBox ("Dosya kopyalama işlemi tamamlandı.")
End Sub

Sub isim_degistir()
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    On Error GoTo son
    For i = 3 To sonsatir
        kaynakisim = Range("A2").Value & "\" & Range("A" & i).Value
        If dosyavarmi(kaynakisim) Then
            yeniisim = Range("A2").Value & "\" & Range("C" & i).Value
            Name kaynakisim As yeniisim
            Range("A" & i).Value = Range("C" & i).Value
            Range("D" & i).Value = ""
            GoTo atla
        Else
          Range("D" & i).Value = "Dosya Yok"
          GoTo atla
        End If
son:
        Range("D" & i).Value = "Değişmedi"
atla:
    Next i
     MsgBox ("Dosya isim değiştirme işlemi tamamlandı.")
End Sub


Function dosyavarmi(dosya)
  Dim ds, a
  Set ds = CreateObject("Scripting.FileSystemObject")
  a = ds.FileExists(dosya)
  If a = True Then
    dosyavarmi = True
  Else
    dosyavarmi = False
  End If
End Function

halit3 · 30 Mart 2019

Dosya taşıma ve kopyalama ekran görüntüsü ve sayfadaki kodlar

Kod:

Private Sub CommandButton1_Click()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Range("A2:A" & Rows.Count).ClearContents

Liste (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub


Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

If Right(yol, 1) <> "\" Then ekle = "\"

On Error Resume Next
For Each Dosya In fL.GetFolder(yol).Files
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("a1:a" & Rows.Count)) + 1
Cells(j, 1) = yol & ekle & Dosya.Name
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub


Private Sub CommandButton2_Click()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For i = 2 To Worksheets(ActiveSheet.Name).Cells(Rows.Count, "A").End(3).Row
eski = Worksheets(ActiveSheet.Name).Cells(i, 1).Value

dosya_adi = fL.GetBaseName(Worksheets(ActiveSheet.Name).Cells(i, 1).Value)
uzanti = "." & fL.GetExtensionName(eski)
yeni = Kaynak & dosya_adi & uzanti

If CreateObject("Scripting.FileSystemObject").FileExists(yeni) = False Then
Worksheets(ActiveSheet.Name).Cells(i, 1).Value = yeni
Name eski As yeni
End If
Next i


Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub


Private Sub CommandButton3_Click()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For i = 2 To Worksheets(ActiveSheet.Name).Cells(Rows.Count, "A").End(3).Row
eski = Worksheets(ActiveSheet.Name).Cells(i, 1).Value

dosya_adi = fL.GetBaseName(Worksheets(ActiveSheet.Name).Cells(i, 1).Value)
uzanti = "." & fL.GetExtensionName(eski)
yeni = Kaynak & dosya_adi & uzanti
If CreateObject("Scripting.FileSystemObject").FileExists(yeni) = False Then

FileCopy eski, yeni
End If
Next i
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub

Private Sub CommandButton4_Click()
Range("A2:A" & Rows.Count).ClearContents
End Sub

halit3 · 30 Mart 2019

Dosya adı değiştir ekran görüntüsü ve sayfaya ait kodlar

Kod:

Private Sub CommandButton1_Click()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

Range("A2:B" & Rows.Count).ClearContents
Range("D2:D" & Rows.Count).ClearContents

Worksheets(ActiveSheet.Name).Cells(1, 5).Value = "OK"

Liste4 (Kaynak)

Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste4(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")


If Right(yol, 1) <> "\" Then ekle = "\"
For Each Dosya In fL.GetFolder(yol).Files
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = Dosya
Cells(j, 2) = Dosya.Name
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste4 (f.Path)
sonraki:
Next

End Sub



Private Sub CommandButton2_Click()
If Worksheets(ActiveSheet.Name).Cells(1, 5).Value <> "OK" Then MsgBox "işlemi yeniden yapaın": Exit Sub
sat1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A65000"))
sat2 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("B2:B65000"))
If sat1 <> sat2 Then
MsgBox "eski dosyalarla değiştirilecek dosyalar sayısı aynı değil", vbInformation, "İşlem Tamam !"
End If
a = MsgBox(" Dosyaların isimlerini değiştirmek İstiyormusunz ?", vbExclamation + vbYesNo, "İşlem Tamam !")
If a = vbNo Then
Exit Sub
End If

For i = 2 To Worksheets(ActiveSheet.Name).Cells(Rows.Count, "A").End(3).Row
eski = Worksheets(ActiveSheet.Name).Cells(i, 1).Value

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

Klasor = fL.GetParentFolderName(eski)
dosya_adi = Worksheets(ActiveSheet.Name).Cells(i, 3).Value
uzanti = "." & fL.GetExtensionName(eski)

yeni = Klasor & "\" & dosya_adi & uzanti
On Error Resume Next

If CreateObject("Scripting.FileSystemObject").FileExists(yeni) = False Then
Worksheets(ActiveSheet.Name).Cells(i, 4).Value = yeni
Name eski As yeni
End If
Next i

Worksheets(ActiveSheet.Name).Cells(1, 5).Value = ""
Worksheets(ActiveSheet.Name).Cells(1, 4).Value = "OK"
MsgBox "işlem tamam"
End Sub



Private Sub CommandButton3_Click()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Range("A2:B" & Rows.Count).ClearContents
Range("D2:D" & Rows.Count).ClearContents
Worksheets(ActiveSheet.Name).Cells(1, 5).Value = "OK"

Liste (Kaynak)

Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub


Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

If Right(yol, 1) <> "\" Then ekle = "\"

On Error Resume Next
For Each Dosya In fL.GetFolder(yol).Files
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("a1:a" & Rows.Count)) + 1
Cells(j, 1) = yol & ekle & Dosya.Name
Cells(j, 2) = fL.GetBaseName(Dosya.Name)

Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

Private Sub CommandButton4_Click()
If Worksheets(ActiveSheet.Name).Cells(1, 4).Value <> "OK" Then MsgBox "işlemi yeniden yapaın": Exit Sub

sat1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A65000"))
sat2 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("B2:B65000"))
If sat1 <> sat2 Then
MsgBox "eski dosyalarla değiştirilecek dosyalar sayısı aynı değil", vbInformation, "İşlem Tamam !"
End If
a = MsgBox(" Dosyaların isimlerini değiştirmek İstiyormusunz ?", vbExclamation + vbYesNo, "İşlem Tamam !")
If a = vbNo Then
Exit Sub
End If

For i = 2 To Worksheets(ActiveSheet.Name).Cells(Rows.Count, "D").End(3).Row
eski = Worksheets(ActiveSheet.Name).Cells(i, 4).Value
yeni = Worksheets(ActiveSheet.Name).Cells(i, 1).Value
Name eski As yeni
Next i
Worksheets(ActiveSheet.Name).Cells(1, 4).Value = ""
Range("D2:D65000").ClearContents
MsgBox "işlem tamam"
End Sub

Private Sub CommandButton5_Click()
Range("A2:B" & Rows.Count).ClearContents
Range("D2:D" & Rows.Count).ClearContents
End Sub

halit3 · 30 Mart 2019

Kolasör adı değiştirmek için ekran görüntüsü ve sayfa kodları

Kod:

Private Sub CommandButton1_Click()
sat = 2
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Range("A2:B" & Rows.Count).ClearContents
Range("D2:D" & Rows.Count).ClearContents
Worksheets(ActiveSheet.Name).Cells(1, 5).Value = "OK"
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).subfolders
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

Say = Say + 1
eski = Dosya
yeni = Kaynak & Format(Say, "000") & " - " & Dosya.Name

Worksheets(ActiveSheet.Name).Cells(sat, 1).Value = Kaynak & Dosya.Name
Worksheets(ActiveSheet.Name).Cells(sat, 2).Value = Dosya.Name
sat = sat + 1
Next

Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

Private Sub CommandButton2_Click()

If Worksheets(ActiveSheet.Name).Cells(1, 5).Value <> "OK" Then MsgBox "işlemi yeniden yapaın": Exit Sub

sat1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A65000"))
sat2 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("B2:B65000"))
If sat1 <> sat2 Then
MsgBox "eski dosyalarla değiştirilecek dosyalar sayısı aynı değil", vbInformation, "İşlem Tamam !"
End If
a = MsgBox(" Dosyaların isimlerini değiştirmek İstiyormusunz ?", vbExclamation + vbYesNo, "İşlem Tamam !")
If a = vbNo Then
Exit Sub
End If

For i = Worksheets(ActiveSheet.Name).Cells(Rows.Count, "A").End(3).Row To 2 Step -1

eski = Worksheets(ActiveSheet.Name).Cells(i, 1).Value
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Klasor = fL.GetParentFolderName(eski)
dosya_adi = Worksheets(ActiveSheet.Name).Cells(i, 3).Value

yeni = Klasor & "\" & dosya_adi
Worksheets(ActiveSheet.Name).Cells(i, 4).Value = yeni

On Error Resume Next
If CreateObject("Scripting.FileSystemObject").FolderExists(yeni) = False Then
Name eski As yeni
End If

Next i

Worksheets(ActiveSheet.Name).Cells(1, 5).Value = ""
Worksheets(ActiveSheet.Name).Cells(1, 4).Value = "OK"
MsgBox "işlem tamam"

End Sub

Private Sub CommandButton3_Click()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

Range("A2:B65000").ClearContents
Range("D2:D65000").ClearContents
Worksheets(ActiveSheet.Name).Cells(1, 5).Value = "OK"
Liste11 (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste11(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
deg = "Yeni Klasör"
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = yol & "\" & f.Name
Cells(j, 2) = f.Name
Liste11 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

Private Sub CommandButton4_Click()
If Worksheets(ActiveSheet.Name).Cells(1, 4).Value <> "OK" Then MsgBox "işlemi yeniden yapaın": Exit Sub
sat1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A65000"))
sat2 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("B2:B65000"))
If sat1 <> sat2 Then
MsgBox "eski dosyalarla değiştirilecek dosyalar sayısı aynı değil", vbInformation, "İşlem Tamam !"
End If
a = MsgBox(" Dosyaların isimlerini değiştirmek İstiyormusunz ?", vbExclamation + vbYesNo, "İşlem Tamam !")
If a = vbNo Then
Exit Sub
End If

For i = 2 To Worksheets(ActiveSheet.Name).Cells(Rows.Count, "D").End(3).Row
eski = Worksheets(ActiveSheet.Name).Cells(i, 4).Value
yeni = Worksheets(ActiveSheet.Name).Cells(i, 1).Value
Name eski As yeni
Next i
Worksheets(ActiveSheet.Name).Cells(1, 4).Value = ""
Range("D2:D65000").ClearContents
MsgBox "işlem tamam"
End Sub

yasin85 · 30 Mart 2019

Her zaman kullana bileceğim ve kullanıla bilecek mükemmel çalışmalar benim çok işimi gördü ve görecek ilerleyen zamanlarda da umarım başka arkadaşlarımızda faydalanır.

Emeklerine sağlık teşekkürler..

halit3 · 4 Nisan 2019

yasin85' Alıntı:
Her zaman kullana bileceğim ve kullanıla bilecek mükemmel çalışmalar benim çok işimi gördü ve görecek ilerleyen zamanlarda da umarım başka arkadaşlarımızda faydalanır.

Emeklerine sağlık teşekkürler..

Teşekkürler iyi çalışmalar

tugkan · 4 Nisan 2019

Sayın @asri ve @halit3 Hocam harikasınız.

RBozkurt · 3 Aralık 2020

Ekteki dosyayı link olarak paylaşma imkanı varmıdır? Teşekkürler..

Asri · 3 Aralık 2020

RBozkurt' Alıntı:
Ekteki dosyayı link olarak paylaşma imkanı varmıdır? Teşekkürler..

İki dosya için tek link
https://we.tl/t-u2jyBFoKcZ

hasanyaprak · 22 Aralık 2022

Asri' Alıntı:
İki dosya için tek link
https://we.tl/t-u2jyBFoKcZ

Hocam dosyayı paylaşma imkanın var mıdır? Transfer süresi dolmuş.

Korhan Ayhan · 22 Aralık 2022

Altın Üyeliğiniz var. Forum alt yapısındaki dosyalara erişiminizin olması gerekiyor.

#2. ve #3. mesajlarda dosyalar bulunuyor.

hasanyaprak · 23 Aralık 2022

Korhan Ayhan' Alıntı:
Altın Üyeliğiniz var. Forum alt yapısındaki dosyalara erişiminizin olması gerekiyor.

#2. ve #3. mesajlarda dosyalar bulunuyor.

Korhan bey aldım bu sayfaya yüklenmiş
Excelleri işimi gördü teşekkür ederim.

sjanaz55 · 31 Ekim 2023

Merhaba, benimde işime yaradı çok teşekkür ederim, şöyle bir modül eklenebilir mi bu çalışmalara?
elimde bir klasör içerisinde 2000 den fazla pdf dosyası var, her pdf dosyası bir ürüne ait, ve dosya adları ürünlerin stok kodlarından oluşuyor.
30 civarı farklı ürün grubuna ilişkin klasörler, ve bu ürün gruplarının alt klasörlerinde stok kodlarından oluşturulmuş klasörler var,

pdf dosyalarım aşağıdaki gibi
ürün0001.pdf
ürün0002.pdf
ürün0032.pdf
ürün1072.pdf

ürün klasörleri aşağıdaki gibi,
c:\ürünler\ürün grubu A\ürün0001\
c:\ürünler\ürün grubu A\ürün0002\
c:\ürünler\ürün grubu C\ürün0032\
c:\ürünler\ürün grubu Z\ürün1072\

oluşturduğum tablo,
A sütununda her ürün için kaynak dosya uzantıları
B sütununda da her ürünü kopyalamak istediğim klasör uzantıları nı hazırladım

yapmak istediğim, kaynak ve hedef uzantılarını her bir ürün için satır satır bir tablo halinde hazırlayıp, tüm pdf lerin olduğu klasördeki bu veriyi, uzantılarının aynı addaki alt klasörlerin içine kopyalamak,
yukarıdaki kodlar ile zaten klasörlerin içersinideki dosyaları excell de tabloya getirebiliyorum ama kopyalama için işin içinden çıkamadım

Yardımcı olursanız sevinirim

Klasör isim değiştirme,kopyalama,taşıma Makro Çalışması

yasin85

Ekli dosyalar

halit3

Uzman

Ekli dosyalar

Asri

Ekli dosyalar

halit3

Uzman

halit3

Uzman

halit3

Uzman

yasin85

halit3

Uzman

tugkan

RBozkurt

𐱅𐰇𐰼𐰚

Asri

hasanyaprak

Korhan Ayhan

Administrator

hasanyaprak

sjanaz55