Eski+Yeni Klasör ismi

[beyaz34]

Üstadlar tekrar merhaba..

A kolana eski isimleri getirdim.
Ama B kolana yeni ismi yazıp değismesini istiyorum ?

şimdiden ve tekrar tekrar teşekkürler............

 

[hamitcan]

Sub Klasor_ad_degistir()
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    yol = "C:\"
    For i = 2 To [a65536].End(3).Row
        eskiadi = yol & Cells(i, 1)
        yeniadi = yol & Cells(i, 2)
        objFSO.MoveFolder eskiadi, yeniadi
    Next
End Sub

 

[halit3]

Üstadlar tekrar merhaba..

A kolana eski isimleri getirdim.
Ama B kolana yeni ismi yazıp değismesini istiyorum ?

şimdiden ve tekrar tekrar teşekkürler............

alternatif kod

Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Sub aktar()
On Error Resume Next
Dim Baslik As String
Baslik = "Kaynak Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.BrowseForFolder(0, Baslik, 50, &H0)
Kaynak = Klasor.items.Item.Path
ListBox1.Clear
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
J = 2
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Klasor.items.Item.Path).SubFolders
Cells(J, 1) = Dosya.Path
eskiadi = Dosya.Path
yeniadi = Klasor.items.Item.Path & "\" & Cells(J, 2)
DosyaSistemi.MoveFolder eskiadi, yeniadi
J = J + 1
Next
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
    
Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub

 

[beyaz34]

Sub Klasor_ad_degistir()
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    yol = "C:\"
    For i = 2 To [a65536].End(3).Row
        eskiadi = yol & Cells(i, 1)
        yeniadi = yol & Cells(i, 2)
        objFSO.MoveFolder eskiadi, yeniadi
    Next
End Sub

Degistir tusuna baştıgım zaman
( objFSO.MoveFolder eskiadi, yeniadi) / (satırında hata veriyor) saygılar..

 

[beyaz34]

halit3 kardesim
bul tusuna baştıgım zaman ...
sizin tarafınızdan verilen kodları kullandıgım zaman ( Sub bul() ) da hata veriyor...

 

[hamitcan]

Galiba dosyalarınızın bulunduğu yolu doğru girmiyorsunuz.

 

[halit3]

halit3 kardesim
bul tusuna baştıgım zaman ...
sizin tarafınızdan verilen kodları kullandıgım zaman ( Sub bul() ) da hata veriyor...

dosyanı ekledim inceleyiniz.

 

[beyaz34]

Hocam haklısınız özür dilerim ellerinize sağlık tesekkürler.

 

[beyaz34]

İyi aksamlar..
Benim sorumum Klasor_ad_degistir de 4 adet Klasör değistiriyor Amaben 1000 de fazla verdiğim zaman işlemm yapmıyor?

++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim deger As String
Sub bul()
On Error Resume Next
Dim Baslik As String
Baslik = "Kaynak Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.BrowseForFolder(0, Baslik, 50, &H0)
Kaynak = Klasor.items.Item.Path
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
j = 2
deger = Klasor.items.Item.Path
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Klasor.items.Item.Path).SubFolders
Cells(j, 1) = Dosya.Path
j = j + 1
Next
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub
Sub değiştir()
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
For j = 2 To 5

eskiadi = Cells(j, 1)
yeniadi = deger & "\" & Cells(j, 2)
DosyaSistemi.MoveFolder eskiadi, yeniadi
Next

MsgBox "işlem tamam"
End Sub

+++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Yardımlarınız için tesekkürler.

 

[halit3]

İyi aksamlar..
Benim sorumum Klasor_ad_degistir de 4 adet Klasör değistiriyor Amaben 1000 de fazla verdiğim zaman işlemm yapmıyor?

++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim deger As String
Sub bul()
On Error Resume Next
Dim Baslik As String
Baslik = "Kaynak Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.BrowseForFolder(0, Baslik, 50, &H0)
Kaynak = Klasor.items.Item.Path
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
j = 2
deger = Klasor.items.Item.Path
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Klasor.items.Item.Path).SubFolders
Cells(j, 1) = Dosya.Path
j = j + 1
Next
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub
Sub değiştir()
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
For j = 2 To 5

eskiadi = Cells(j, 1)
yeniadi = deger & "\" & Cells(j, 2)
DosyaSistemi.MoveFolder eskiadi, yeniadi
Next

MsgBox "işlem tamam"
End Sub

+++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Yardımlarınız için tesekkürler.

sorun burada

For j = 2 To 5

yukarıdaki kodu bununla değiştirin

For j = 2 To 1000

 

[beyaz34]

halit3 hovcama tesekkür ederim...