בקשה | מיון קבצים מרובים לתיקיות לפי קובץ אקסל

[סתם אחד 2]

היי
יש לי קובץ אקסל שבו בעמודה הראשונה שמות קבצים ובעמודה השניה הקטגוריה שלהם
אני מעוניין להעביר את כלל הקבצצים לתתי תיקיות לפי הקטגוריות שבקובץ
האם יש תוכנה כל שהיא העושה זאת
באשכול המצורף דובר על בעיה דומה אך לא הצלחתי להגיע לתוצאה רצויה
האם יש אפשרות להעלות קובץ מקומפל בכדי לעשות זאת באופן פשוט
תודה רבה!
https://mitmachim.top/topic/72044/בירור-מיון-קבצים-מרובים-לפי-שמות/25

[שלמה11]

@סתם-אחד-2
הנה קוד VBA באדיבות GPT

Sub סידור_קבצים()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim sourceFolder As String
    Dim fileBaseName As String
    Dim category As String
    Dim fileFound As Boolean
    Dim fileName As String
    Dim targetFolder As String
    Dim fso As Object
    Dim folderPicker As FileDialog
    Dim fileItem As Object
    Dim folder As Object

    ' בחירת תיקיית המקור
    Set folderPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With folderPicker
        .Title = "בחר את תיקיית הקבצים"
        .AllowMultiSelect = False
        If .Show <> -1 Then
            MsgBox "לא נבחרה תיקייה. הפעולה הופסקה.", vbExclamation
            Exit Sub
        End If
        sourceFolder = .SelectedItems(1)
        If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"
    End With

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ws = ThisWorkbook.Sheets(1)
    Set folder = fso.GetFolder(sourceFolder)
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    For i = 2 To lastRow
        fileBaseName = Trim(ws.Cells(i, 1).Value)
        category = Trim(ws.Cells(i, 2).Value)
        fileFound = False

        If fileBaseName <> "" And category <> "" Then
            ' חיפוש קובץ עם שם מתאים (ללא סיומת)
            For Each fileItem In folder.Files
                If LCase(fso.GetBaseName(fileItem.Name)) = LCase(fileBaseName) Then
                    fileName = fileItem.Name
                    fileFound = True
                    Exit For
                End If
            Next fileItem

            If fileFound Then
                targetFolder = sourceFolder & category & "\"
                If Not fso.FolderExists(targetFolder) Then
                    fso.CreateFolder targetFolder
                End If
                fso.MoveFile sourceFolder & fileName, targetFolder & fileName
                Debug.Print "? הועבר: " & fileName & " ? " & category
            Else
                Debug.Print "? לא נמצא קובץ עבור: " & fileBaseName
            End If
        End If
    Next i

    MsgBox "ההעברה בוצעה בהצלחה", vbInformation
End Sub