Dosyaları Başka Bir Klasöre Taşıma

[ahmed_ummu]

Merhaba arkadaşlar.
Aşağıdaki kodu ChatGPT'den aldım ama bir türlü dosyaları klasöre taşıyamadım. Kodun en sonundaki "dosyalar başarılı şekilde taşında" klasöre taşındı mesajı veriyor ama dosyalar klasöre taşınmıyor. Yardımcı olursanız çok sevinirim.

Taşınacak dosyalar Desktop\OKUL_MUHASEBE_BÜRO_KLASÖRLERİ\ÇOKLU İSİM DEĞİŞTİRME\" içindeki STAJYER ÖĞRENCİ klasöründe. Bu klasör (STAJYER ÖĞRENCİ) combobox ile seçliyor. Bu klasördeki dosyalar, dosya adının son kelimesine göre STAJYER ÖĞRENCİLER klasörünün içindeki ANAOKULLARI veya İLKOKULLAR klasörünün içine taşınacak.

Private Sub CommandButton2_Click()
DosyalariKlasoreTasi
End Sub

Sub DosyalariKlasoreTasi()
If ComboBox1.Value = "" Then
MsgBox "Lütfen bir klasör seçiniz.", vbExclamation, "Uyarı"
Exit Sub
End If

Dim FSO As Object
Dim folderPath As String
Dim ilkokullarPath As String
Dim anaokullarPath As String
Dim selectedFolderPath As String
Dim file As Object
Dim newFilePath As String
Dim filename As String
Dim lastWord As String

' Klasör yolları
folderPath = Environ("USERPROFILE") & "\Desktop\OKUL_MUHASEBE_BÜRO_KLASÖRLERİ\ÇOKLU İSİM DEĞİŞTİRME\"

' Kullanıcı tarafından seçilen klasörü belirle
selectedFolderPath = folderPath & ComboBox1.Value

' Dosya sistemi nesnesi oluştur
Set FSO = CreateObject("Scripting.FileSystemObject")

' Seçilen klasörde ANAOKULLARI ve İLKOKULLAR klasörlerini oluştur
ilkokullarPath = selectedFolderPath & "\İLKOKULLAR"
anaokullarPath = selectedFolderPath & "\ANAOKULLAR"

' Klasörleri kontrol et ve yoksa oluştur
If Not FSO.FolderExists(ilkokullarPath) Then
FSO.CreateFolder ilkokullarPath
End If
If Not FSO.FolderExists(anaokullarPath) Then
FSO.CreateFolder anaokullarPath
End If

' Klasördeki dosyaları işle
For Each file In FSO.GetFolder(selectedFolderPath).Files
filename = file.Name

' Dosya adının son kelimesini al
lastWord = SonKelimeyiAl(filename)

' Son kelimeye göre klasör belirle ve dosyayı taşı
If InStr(UCase(lastWord), "İLKOKULU") > 0 Or InStr(UCase(lastWord), "ORTAOKULU") > 0 Then
newFilePath = ilkokullarPath & "\" & filename
On Error Resume Next
file.Move newFilePath
If Err.Number <> 0 Then
MsgBox "Dosya taşıma hatası: " & filename & vbCrLf & Err.Description, vbCritical, "Hata"
Err.Clear
End If
On Error GoTo 0
ElseIf InStr(UCase(lastWord), "ANAOKULU") > 0 Then
newFilePath = anaokullarPath & "\" & filename
On Error Resume Next
file.Move newFilePath
If Err.Number <> 0 Then
MsgBox "Dosya taşıma hatası: " & filename & vbCrLf & Err.Description, vbCritical, "Hata"
Err.Clear
End If
On Error GoTo 0
Else
newFilePath = selectedFolderPath & "\" & filename
On Error Resume Next
file.Move newFilePath
If Err.Number <> 0 Then
MsgBox "Dosya taşıma hatası: " & filename & vbCrLf & Err.Description, vbCritical, "Hata"
Err.Clear
End If
On Error GoTo 0
End If
Next file

' İşlem tamamlandığında bilgi mesajı göster
MsgBox ComboBox1.Value & " klasörü içindeki dosyalar başarıyla taşındı.", vbInformation

ComboBox1.Clear
End Sub

Function SonKelimeyiAl(ByVal dosyaAdi As String) As String
Dim kelimeler() As String
kelimeler = Split(dosyaAdi, " ")
SonKelimeyiAl = kelimeler(UBound(kelimeler))
End Function

 

[Korhan Ayhan]

Merhaba,

Bahsettiğiniz klasörler var olduğunu varsaydım..

Option Explicit

Private Sub CommandButton1_Click()
    Dim FSO As Object, Main_Folder As String
    Dim Sub_Folder_1 As String, Sub_Folder_2 As String
    Dim My_File As Object, My_File_Name_Text As Variant
    Dim Last_Text As String
    
    If ComboBox1 = "" Then
        MsgBox "Lütfen bir klasör seçiniz!", vbCritical
        Exit Sub
    End If
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Main_Folder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\OKUL_MUHASEBE_BÜRO_KLASÖRLERİ\ÇOKLU İSİM DEĞİŞTİRME\" & ComboBox1 & "\"
    Sub_Folder_1 = Main_Folder & "\İLKOKULLAR\"
    Sub_Folder_2 = Main_Folder & "\ANAOKULLARI\"

    For Each My_File In FSO.GetFolder(Main_Folder).Files
        My_File_Name_Text = Split(My_File.Name, " ")
        Last_Text = UCase(Replace(Replace(My_File_Name_Text(UBound(My_File_Name_Text)), "ı", "I"), "i", "İ"))
        If InStr(1, Last_Text, "İLKOKUL") > 0 Or InStr(1, Last_Text, "ORTAOKULU") > 0 Then
            My_File.Move Sub_Folder_1 & My_File.Name
        End If
    
        If InStr(1, Last_Text, "ANAOKUL") > 0 Then
            My_File.Move Sub_Folder_2 & My_File.Name
        End If
    Next
    
    Set FSO = Nothing
    
    MsgBox "Dosya taşıma işlemi tamamlanmıştır.", vbInformation
End Sub

 

[ahmed_ummu]

Merhaba,

Bahsettiğiniz klasörler var olduğunu varsaydım..

Option Explicit

Private Sub CommandButton1_Click()
    Dim FSO As Object, Main_Folder As String
    Dim Sub_Folder_1 As String, Sub_Folder_2 As String
    Dim My_File As Object, My_File_Name_Text As Variant
    Dim Last_Text As String
   
    If ComboBox1 = "" Then
        MsgBox "Lütfen bir klasör seçiniz!", vbCritical
        Exit Sub
    End If
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
   
    Main_Folder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\OKUL_MUHASEBE_BÜRO_KLASÖRLERİ\ÇOKLU İSİM DEĞİŞTİRME\" & ComboBox1 & "\"
    Sub_Folder_1 = Main_Folder & "\İLKOKULLAR\"
    Sub_Folder_2 = Main_Folder & "\ANAOKULLARI\"

    For Each My_File In FSO.GetFolder(Main_Folder).Files
        My_File_Name_Text = Split(My_File.Name, " ")
        Last_Text = UCase(Replace(Replace(My_File_Name_Text(UBound(My_File_Name_Text)), "ı", "I"), "i", "İ"))
        If InStr(1, Last_Text, "İLKOKUL") > 0 Or InStr(1, Last_Text, "ORTAOKULU") > 0 Then
            My_File.Move Sub_Folder_1 & My_File.Name
        End If
   
        If InStr(1, Last_Text, "ANAOKUL") > 0 Then
            My_File.Move Sub_Folder_2 & My_File.Name
        End If
    Next
   
    Set FSO = Nothing
   
    MsgBox "Dosya taşıma işlemi tamamlanmıştır.", vbInformation
End Sub

Kodlar için çok teşekkürler Korhan bey.

Aşağıdaki mesajı verdi ama klasöre dosyaları taşımadı.

MsgBox "Dosya taşıma işlemi tamamlanmıştır.", vbInformation

 

[ahmed_ummu]

Kodlar için çok teşekkürler Korhan bey.

Aşağıdaki mesajı verdi ama klasöre dosyaları taşımadı.

MsgBox "Dosya taşıma işlemi tamamlanmıştır.", vbInformation

Çok teşekkürler Korhan bey, şimdi düzeldi. Klasörün adının sonuna fazladan I harfi yazılmış onu silince düzeldi.