Klasörden dosya taşımak

[metin_0606]

C:\ nin icinde kimlik isimli klasörüm var. Bu klasörün içinde personele ait TC kimlik numaralarina göre isimlendirilmiş PDF uzantılı dosyalar var. Ben işten ayrılan personele ait dosyaları bu klasörün içinden alıp yine C: nin içindeki işten ayrılan isimli klasöre taşımak istiyorum. Bunu şu şekilde yapmak mümkünmü acaba . Sayfa 1 isimli Excel sayfamın A sütununa yazdığım TC kimlik numaralarina ait dosyaları kimlik isimli klasörün içinden alıp işten ayrılan isimli klasöre taşısın istiyorum. Klasörün içindeki yaklaşık 6000 veri var. Yardımlarınız için şimdiden teşekkürler

 

[PLİNT]

Merhaba
Aşağıdaki kodları deneyiniz
(Taşınanlar "yeşil" , bulunamayan olursa "kırmızı" olacak)

Private Sub CommandButton1_Click()
    Dim A As Object, dsy As String
    Dim Klas1 As String
    Dim Klas2 As String
    Klas1 = "C:\kimlik\"
    Klas2 = "C:\işten ayrılan"
    Set A = CreateObject("scripting.filesystemobject")
If Not A.FolderExists(Klas2) Then MkDir Klas2
For i = 1 To Cells(Rows.Count, "A").End(3).Row
If Trim(Cells(i, "A").Value) <> "" Then
dsy = Trim(Cells(i, "A").Value) & ".pdf"
If A.FileExists(Klas1 & dsy) = True Then
A.moveFile Source:=Klas1 & dsy, Destination:=Klas2 & "\"
Cells(i, "A").Interior.ColorIndex = 4
Else
Cells(i, "A").Interior.ColorIndex = 3
End If: End If
Next
End Sub

 

[metin_0606]

Merhaba
Aşağıdaki kodları deneyiniz
(Taşınanlar "yeşil" , bulunamayan olursa "kırmızı" olacak)

Private Sub CommandButton1_Click()
    Dim A As Object, dsy As String
    Dim Klas1 As String
    Dim Klas2 As String
    Klas1 = "C:\kimlik\"
    Klas2 = "C:\işten ayrılan"
    Set A = CreateObject("scripting.filesystemobject")
If Not A.FolderExists(Klas2) Then MkDir Klas2
For i = 1 To Cells(Rows.Count, "A").End(3).Row
If Trim(Cells(i, "A").Value) <> "" Then
dsy = Trim(Cells(i, "A").Value) & ".pdf"
If A.FileExists(Klas1 & dsy) = True Then
A.moveFile Source:=Klas1 & dsy, Destination:=Klas2 & "\"
Cells(i, "A").Interior.ColorIndex = 4
Else
Cells(i, "A").Interior.ColorIndex = 3
End If: End If
Next
End Sub

Sayın plint kırmızı ve yeşil olacak derken excelin A sütununa yazdığım TC kimlik numaraları icinmi hücrede renklendirme olacak taşınıp tasinamadigina göre

 

[PLİNT]

"A" sütunundaki hücrede yazılı "TC no" ile adlandırılmış "kimlik" klasörü içinde "pdf" dosyası bulamazsa
"A" hücresi kırmızı olur böylece bir hata olduğunu (taşınmayan bir dosya olduğunu) anlarsınız diye eklemiştim.
Cells(i, "A").Interior.ColorIndex kodlarda iki satırda isterseniz silin

 

[metin_0606]

"A" sütunundaki hücrede yazılı "TC no" ile adlandırılmış "kimlik" klasörü içinde "pdf" dosyası bulamazsa
"A" hücresi kırmızı olur böylece bir hata olduğunu (taşınmayan bir dosya olduğunu) anlarsınız diye eklemiştim.
Cells(i, "A").Interior.ColorIndex kodlarda iki satırda isterseniz silin

Bence gayet mantıklı olmuş kodu yarın deneyip size dönüş yaparım teşekkür ederim yardiminizdan dolayı

 

[metin_0606]

Merhaba
Aşağıdaki kodları deneyiniz
(Taşınanlar "yeşil" , bulunamayan olursa "kırmızı" olacak)

Private Sub CommandButton1_Click()
    Dim A As Object, dsy As String
    Dim Klas1 As String
    Dim Klas2 As String
    Klas1 = "C:\kimlik\"
    Klas2 = "C:\işten ayrılan"
    Set A = CreateObject("scripting.filesystemobject")
If Not A.FolderExists(Klas2) Then MkDir Klas2
For i = 1 To Cells(Rows.Count, "A").End(3).Row
If Trim(Cells(i, "A").Value) <> "" Then
dsy = Trim(Cells(i, "A").Value) & ".pdf"
If A.FileExists(Klas1 & dsy) = True Then
A.moveFile Source:=Klas1 & dsy, Destination:=Klas2 & "\"
Cells(i, "A").Interior.ColorIndex = 4
Else
Cells(i, "A").Interior.ColorIndex = 3
End If: End If
Next
End Sub

Sayın plint kod gayet güzel çalıştı. Ancak klasörün içindeki dosya isimleri TC kimlik numarası artı isim soy isim olunca taşıma işlemi yapmıyor Örneğin 12345678901 MERT ATAKAN .PDF OLUNCA TASİMA YAPMİYOR.

Merhaba
Aşağıdaki kodları deneyiniz
(Taşınanlar "yeşil" , bulunamayan olursa "kırmızı" olacak)

Private Sub CommandButton1_Click()
    Dim A As Object, dsy As String
    Dim Klas1 As String
    Dim Klas2 As String
    Klas1 = "C:\kimlik\"
    Klas2 = "C:\işten ayrılan"
    Set A = CreateObject("scripting.filesystemobject")
If Not A.FolderExists(Klas2) Then MkDir Klas2
For i = 1 To Cells(Rows.Count, "A").End(3).Row
If Trim(Cells(i, "A").Value) <> "" Then
dsy = Trim(Cells(i, "A").Value) & ".pdf"
If A.FileExists(Klas1 & dsy) = True Then
A.moveFile Source:=Klas1 & dsy, Destination:=Klas2 & "\"
Cells(i, "A").Interior.ColorIndex = 4
Else
Cells(i, "A").Interior.ColorIndex = 3
End If: End If
Next
End Sub

Sayın plint kod gayet güzel çalıştı. Ancak klasörün içindeki dosya isimleri 12345678901 MERT ATAKAN.PDF OLUNCA tasima yapmıyor. Sadece TC kimlik numarası ile isimlendirildiginde taşıma yapıyor. Buna göre kodda nasıl bir değişiklik yapabiliriz

 

[PLİNT]

Merhaba
"Kimlik" klasörü içinde aynı "TC" no ile adlandırılmış (başlayan "pdf" den) başka uzantılı dosya olmayacağına göre:
Kodların içindeki şu satırı

dsy = Trim(Cells(i, "A").Value) & ".pdf"

şöyle değişerek deneyin

dsy = Dir(Klas1 & trim(Cells(i, "A").Value) & "*.*", vbDirectory)

 

[metin_0606]

Merhaba
"Kimlik" klasörü içinde aynı "TC" no ile adlandırılmış (başlayan "pdf" den) başka uzantılı dosya olmayacağına göre:
Kodların içindeki şu satırı

dsy = Trim(Cells(i, "A").Value) & ".pdf"

şöyle değişerek deneyin

dsy = Dir(Klas1 & trim(Cells(i, "A").Value) & "*.*", vbDirectory)

Teşekkürler sayın plint kod süper