excel listesine göre klasörler arası dosya kopyalama

[hasanyaprak]

Excelin A1 sutunundan başlayarak alta doğru inen bir listem var. Bu listedeki isimleri klasör altından bulursa başka bir klasöre kopyalama yapıyor. A1 hücresinden başlamasın istiyorum. Mesela D3 ten başlayarak listem D100 e kadar baksın. Bunu yapabilmek için kodda neler değişmeli yardımcı olabilirseniz memnun olurum. Tşk.

Private Sub CommandButton1_Click()


MsgBox "********."
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
veriKlasor = "C:\Users\xxxxxxx\"
HedefKlasor = "C:\Users\xxxxx\PROJEYE_OZEL\"
On Error Resume Next
For i = 1 To [a65536].End(3).Row
Dosya = veriKlasor & Cells(i, 1).Value & ".pdf"
Cells(1, 1).Interior.ColorIndex = xlNone
If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
DosyaSistemi.CopyFile Dosya, HedefKlasor & Cells(1, 1).Value & ".pdf"
'DosyaSistemi.MoveFile Dosya, HedefKlasor & Cells(i, 1).Value & ".pdf" dosya taşıma için
Else
Cells(i, 1).Interior.ColorIndex = 3
End If
Next i
MsgBox "KOPYALAMA TAMAMLANDI."
' End If
End Sub

 

[Levent Menteşoğlu]

Aşağıdaki kırmızı renkli değişiklikleri yaparak deneyin.

Private Sub CommandButton1_Click()


MsgBox "********."
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
veriKlasor = "C:\Users\xxxxxxx\"
HedefKlasor = "C:\Users\xxxxx\PROJEYE_OZEL\"
On Error Resume Next
For i = 3 To 100
Dosya = veriKlasor & Cells(i, 4).Value & ".pdf"
Cells(1, 4).Interior.ColorIndex = xlNone
If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
DosyaSistemi.CopyFile Dosya, HedefKlasor & Cells(1, 4).Value & ".pdf"
'DosyaSistemi.MoveFile Dosya, HedefKlasor & Cells(i, 4).Value & ".pdf" dosya taşıma için
Else
Cells(i, 4).Interior.ColorIndex = 3
End If
Next i
MsgBox "KOPYALAMA TAMAMLANDI."
' End If
End Sub

 

[hasanyaprak]

Aşağıdaki kırmızı renkli değişiklikleri yaparak deneyin.

Private Sub CommandButton1_Click()


MsgBox "********."
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
veriKlasor = "C:\Users\xxxxxxx\"
HedefKlasor = "C:\Users\xxxxx\PROJEYE_OZEL\"
On Error Resume Next
For i = 3 To 100
Dosya = veriKlasor & Cells(i, 4).Value & ".pdf"
Cells(1, 4).Interior.ColorIndex = xlNone
If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
DosyaSistemi.CopyFile Dosya, HedefKlasor & Cells(1, 4).Value & ".pdf"
'DosyaSistemi.MoveFile Dosya, HedefKlasor & Cells(i, 4).Value & ".pdf" dosya taşıma için
Else
Cells(i, 4).Interior.ColorIndex = 3
End If
Next i
MsgBox "KOPYALAMA TAMAMLANDI."
' End If
End Sub

Teşekkür ederim Levent bey istediğim oldu.