6-كود كتابة اسامى الملفات من خلال الاكسل بضغط زر مع تثبيت الكود كإيقونة فى كل شيتات الاكسل .

[@QuantitiesSurveying]

*الكود المستخدم فى الفيديو
Sub RenameFiles()
Dim ws As Worksheet
Dim selectedCells As Range
Dim cell As Range
Dim fso As Object
Dim fd As FileDialog
Dim selectedFiles As Variant
Dim i As Integer
Dim fileCount As Integer
Dim oldFileName As String
Dim fileExtension As String
Dim newFileName As String
Dim cellCount As Integer
Dim hasEmptyCells As Boolean
Dim baseName As String
Dim newNameWithoutCounter As String
Dim nameDict As Object
Dim duplicateNames As Boolean
Dim colorDict As Object
Dim colorIndex As Integer
Dim usedColors As Object
Dim color As Long
' تعيين الورقة النشطة
Set ws = ActiveSheet
' التحقق من أن التحديد هو نطاق
If TypeName(Selection) "Range" Then
MsgBox "يرجى تحديد نطاق من الخلايا التي تحتوي على الأسماء الجديدة للملفات."
Exit Sub
End If
Set selectedCells = Selection
' التحقق من وجود خلايا فارغة في التحديد
cellCount = selectedCells.Cells.Count
hasEmptyCells = False
For Each cell In selectedCells
If cell.Value = "" Then
hasEmptyCells = True
Exit For
End If
Next cell
If hasEmptyCells Then
MsgBox "التحديد يحتوي على خلايا فارغة. يرجى التأكد من أن جميع الخلايا تحتوي على قيمة."
Exit Sub
End If
' تهيئة كائن نظام الملفات والقاموس لتتبع الأسماء
Set fso = CreateObject("Scripting.FileSystemObject")
Set nameDict = CreateObject("Scripting.Dictionary")
Set colorDict = CreateObject("Scripting.Dictionary")
Set usedColors = CreateObject("Scripting.Dictionary")
' التحقق من وجود أسماء مكررة وتلوين الخلايا المكررة
duplicateNames = False
colorIndex = 3 ' بداية مؤشر الألوان (نبدأ من 3 لأن 1 و 2 محفوظين للألوان الأحمر والأصفر)
For Each cell In selectedCells
baseName = cell.Value
If nameDict.Exists(baseName) Then
duplicateNames = True
If colorDict.Exists(baseName) Then
color = colorDict(baseName)
Else
' تحديد لون جديد غير مستخدم
Do
colorIndex = colorIndex + 1
color = RGB((colorIndex * 20) Mod 128, (colorIndex * 40) Mod 128, (colorIndex * 60) Mod 128)
Loop While usedColors.Exists(color)
' حفظ اللون كونه مستخدم
usedColors.Add color, 1
colorDict.Add baseName, color
End If
cell.Interior.Color = color ' تلوين الخلايا المكررة بلون مختلف
Else
nameDict.Add baseName, 1
cell.Interior.ColorIndex = xlNone ' إزالة التلوين من الخلايا غير المكررة
End If
Next cell
' إذا كانت هناك أسماء مكررة، عرض رسالة وإنهاء
If duplicateNames Then
MsgBox "يوجد أسماء مكررة في التحديد يرجى تحديث الأسماء قبل المتابعة"
Exit Sub
End If
' فتح مربع الحوار لتحديد الملفات
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.Title = "اختر الملفات التي تريد إعادة تسميتها"
fd.AllowMultiSelect = True
fd.Filters.Clear
fd.Filters.Add "All Files", "*.*"
' عرض مربع الحوار وتخزين الملفات المختارة
If fd.Show = -1 Then
fileCount = fd.SelectedItems.Count
ReDim selectedFiles(1 To fileCount)
For i = 1 To fileCount
selectedFiles(i) = fd.SelectedItems(i)
Next i
Else
Exit Sub
End If
' التحقق من أن عدد الملفات المختارة يطابق عدد الخلايا في التحديد
If fileCount cellCount Then
MsgBox "عدد الملفات المختارة لا يطابق عدد الخلايا في التحديد."
Exit Sub
End If
' إعادة تسمية الملفات
i = 1
For Each cell In selectedCells
baseName = cell.Value
oldFileName = selectedFiles(i)
fileExtension = "." & fso.GetExtensionName(oldFileName)
newFileName = fso.BuildPath(fso.GetParentFolderName(oldFileName), baseName & fileExtension)
' محاولة إعادة تسمية الملف
On Error Resume Next
fso.MoveFile oldFileName, newFileName
If Err.Number 0 Then
MsgBox "خطأ في إعادة تسمية الملف: " & Err.Description
Err.Clear
End If
On Error GoTo 0
i = i + 1
Next cell
'MsgBox "تمت عملية إعادة تسمية الملفات بنجاح!"
' تنظيف
Set fso = Nothing
Set fd = Nothing
Set nameDict = Nothing
Set colorDict = Nothing
Set usedColors = Nothing
End Sub

[@AsmaaRefaai-p8o]

بالتوفيق دائما وأبدا