@סתם-אחד-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
![חיפוש גוגל בפורום](javascript:{bootbox.prompt({title:'<div style="text-align: center;"><img src="/assets/uploads/files/1625950269825-mt-google.png" width="400"></div>',placeholder:'כתוב מילים לחיפוש ב Google',buttons:{confirm:{label:'חיפוש'},cancel:{label:'ביטול'}},backdrop:true,callback:function(result){if(result!=null&&result!=''){var a=document.createElement('a');a.href='https://www.google.co.il/search?q=site:mitmachim.top '+encodeURIComponent(result.trim());a.target='_blank';a.click();}}})();};){kind=link}