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

[שלמה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

[סתם אחד 2]

@שלמה11
תודה רבה!
הסקריפט מפעיל את עצמו ואף עולה הודעה לבסוף שהקבצים הועברו בהצלחה
אך למעשה לא קורה כלום והקבצים לא הוברו לתיקיות
אשמח אם תוכל לעזור בענין

[אופיר123]

@סתם-אחד-2 קצת לא הבנתי את הבקשה, באיזו תיקיה הקבצים נמצאים כעת? כולם יחד? להעביר אותם לתיקיות אחרות שמה השם שלהם? שמות הקטגוריות?

[סתם אחד 2]

@אופיר123
כלל הקבצים נמצאים כעת בתיקיית אחת ואני מעוניין לחלק אותם לפי קטגוריות
בקובץ יש שני עמודות אחד של שם הקובץ והשני שם של הקטגוריה כלומר שם התיקייה שאני מעוניים שהקובץ יעבור אליו.

[שלמה11]

@סתם-אחד-2 אני בדקתי את הסקריפט והוא עובד כמו שצריך, צריך ששמות הקבצים יהיו בעמודה הראשונה ושמות התיקיות בעמודה השניה של המסמך.
צריך ג"כ ששמות הקבצים והתיקיות יהיו מדויקים

[סתם אחד 2]

@שלמה11
כלומר הוא מעביר את הקבצים רק במקרה שהתיקיות קיימות?
ניתן להוסיף לסקריפט אפשרות שבמקרה שאין תיקייה קיימת הוא יצור תיקייה?

תודה רבה!

[ע"ה דכו"ע]

@סתם-אחד-2 כתב בבקשה | מיון קבצים מרובים לתיקיות לפי קובץ אקסל:

@שלמה11
כלומר הוא מעביר את הקבצים רק במקרה שהתיקיות קיימות?
ניתן להוסיף לסקריפט אפשרות שבמקרה שאין תיקייה קיימת הוא יצור תיקייה?

תודה רבה!

לא, מעיון במאקרו הוא מוסיף את התיקיה במקרה שהיא לא קיימת (בשורה 52), רק השמות של הקבצים צריכים להיות מדוייקים.

[סתם אחד 2]

@ע-amp-amp-amp-quot-ה-דכו-amp-amp-amp-quot-ע

מה זאת אומרת ששמות הקבצים צריכים להיות מדוייקים?

[ע"ה דכו"ע]

@סתם-אחד-2 כתב בבקשה | מיון קבצים מרובים לתיקיות לפי קובץ אקסל:

@ע-amp-amp-amp-quot-ה-דכו-amp-amp-amp-quot-ע

מה זאת אומרת ששמות הקבצים צריכים להיות מדוייקים?

השמות של הקבצים להעברה שבטבלה באקסל.

[ע"ה דכו"ע]

@סתם-אחד-2
שים לב שהשמות של הקבצים שבאקסל כתובים בלי הסיומת, וכן אולי כדאי להוסיף TRIM גם בשמות הקבצים של התיקייה, כלומר אתה יכול לשנות את שורה 42 במאקרו מ

                If LCase(fso.GetBaseName(fileItem.Name)) = LCase(fileBaseName) Then

ל

                If Trim(LCase(fso.GetBaseName(fileItem.Name))) = LCase(fileBaseName) Then